forth-wordlist wordlist dup set-current 2 set-order : assert ( n -- ) 0= if abort then ; : linked-list create 0 , 0 , ; : allocate' ( n -- a ) allocate 0= assert ; : zero ( a n -- ) 0 fill ; : allocate0 ( n -- a ) dup allocate' swap 2dup zero drop ; : chain-new ( n -- a ) 1+ cells allocate0 ; : chain-fillout ( .. a n -- a ) 0 do dup i 1+ cells + swap >r ! r> loop ; : chain-link ( ..n -- a ) dup chain-new swap chain-fillout ; : chain-first ( ..n head[t] -- ) >r chain-link r> 2dup ! cell+ ! ; : chain-rest ( ..n head[t] -- ) >r chain-link r> 2dup cell+ @ ! cell+ ! ; : chain ( ..n head[t] -- ) dup @ if chain-rest else chain-first then ; : ->next ( a -- a' ) @ ; : $clone ( $ - $ ) dup allocate 0= assert swap 2dup >r >r move r> r> ; : 3dup ( xyz -- xyzxyz ) dup 2over rot ; : atom-length@ ( A -- n ) 1 cells + @ ; : atom-data@ ( A -- a ) 2 cells + @ ; : atom-string@ ( A -- $ ) dup atom-data@ swap atom-length@ ; : atom-meaning-head ( A -- A[head] ) 3 cells + ; linked-list atom-root : $atom-new ( $ -- A ) >r >r 0 0 r> r> 4 atom-root chain atom-root cell+ @ ; : atom-new ( $ -- A ) $clone $atom-new ; : atom= ( $ A -- f ) atom-string@ compare 0= ; : atom-find' ( $ A -- A ) begin dup 0= if nip nip exit then 3dup atom= if nip nip exit then ->next again ; : atom-find ( $ -- A ) atom-root @ atom-find' ; : $atom ( $ -- A ) 2dup atom-find dup if nip nip else drop $atom-new then ; : atom ( $ -- A ) 2dup atom-find dup if nip nip else drop atom-new then ; : atom. ( A -- ) atom-string@ type ; : atoms. ( -- ) atom-root @ begin dup while dup atom. cr ->next repeat drop ; : atom" ( -- A ) [char] " parse state @ if postpone sliteral postpone atom else atom then ; immediate : atom{ ( -- A ) [char] } parse state @ if postpone sliteral postpone atom else atom then ; immediate : atom"" ( -- A ) 0 0 atom ; : atom-append ( A n Ad -- ) atom-meaning-head 2 swap chain ; : atom+=$ ( A Ad -- ) 0 swap atom-append ; : atom+=ref ( A Ad -- ) 1 swap atom-append ; : ref-parts ( ref -- A ref? ) cell+ dup cell+ @ swap @ ; : atom-walk ( fn A -- ) atom-meaning-head @ begin dup while 2dup >r >r ref-parts if recurse else swap execute then r> r> ->next repeat 2drop ; : tally-length ( n A -- n ) atom-length@ + ; : gather-string ( a A -- a' ) 2dup atom-string@ >r swap r> move tally-length ; : atom-walk-length ( A -- n ) 0 swap ['] tally-length swap atom-walk ; : atom-walk-gather ( a A -- ) swap ['] gather-string swap atom-walk drop ; : means ( A -- A' ) dup atom-walk-length dup allocate 0= assert swap 2dup >r >r drop atom-walk-gather r> r> $atom ; : atom>>$ ( A d -- d' ) 2dup >r atom-string@ r> swap move swap atom-length@ + ; : atom+ ( A A -- A ) swap 2dup atom-length@ swap atom-length@ + dup >r allocate 0= assert dup >r atom>>$ atom>>$ drop r> r> $atom ; : atom-ch ( ch -- A ) 1 allocate 0= assert 2dup c! nip 1 atom ; 10 atom-ch constant atom-cr : atom-cr+ ( A -- A ) atom-cr atom+ ; atom" foo" atom" foo" = assert atom" bar" atom" foo" <> assert atom" testing" atom" 123" atom+ atom" testing123" = assert atom" abc" atom" bar" atom+=$ atom" def" atom" bar" atom+=$ atom" 1234" atom" foo" atom+=$ atom" bar" atom" foo" atom+=ref atom" 5678 9" atom" foo" atom+=$ atom" bar" atom" foo" atom+=ref atom" foo" means atom" 1234abcdef5678 9abcdef" = assert : file!-dangle ( A A -- fileid ) atom-string@ r/w bin create-file 0= assert swap over >r atom-string@ r> write-file 0= assert dup flush-file 0= assert ; : file! ( A A -- ) file!-dangle close-file 0= assert ; : file!-tmp ( A A -- fileid ) file!-dangle dup 0 s>d rot reposition-file 0= assert ; : escape-ch ( ch -- ) dup [char] < = if [char] & c, [char] l c, [char] t c, [char] ; c, drop exit then dup [char] > = if [char] & c, [char] g c, [char] t c, [char] ; c, drop exit then dup [char] " = if [char] & c, [char] q c, [char] u c, [char] o c, [char] t c, [char] ; c, drop exit then dup [char] & = if [char] & c, [char] a c, [char] m c, [char] p c, [char] ; c, drop exit then c, ; : escape-each ( A -- ) atom-string@ 0 ?do dup i + c@ escape-ch loop drop ; : here! ( a -- ) here - allot ; : escape ( A -- A ) here dup >r swap escape-each here over - atom r> here! ; : source@ source ( -- a ) drop >in @ + ; : source-remaining ( -- n ) source nip >in @ - ; : drop| ( -- ) source@ 1- c@ [char] | = if -1 >in +! then ; : need-refill? ( -- f) source nip >in @ <= ; : on|? ( -- f ) need-refill? if false exit then source@ c@ [char] | = ; : replenish ( -- f ) need-refill? if refill else true then ; : ?atom-cr+ ( A -- A ) on|? 0= if atom-cr+ then ; : eat| ( -- ) [char] | parse drop| atom atom+ ?atom-cr+ ; : parse..| ( -- A ) atom"" begin replenish 0= if exit then eat| on|? until ; : parse-cr ( -- A ) source@ source-remaining atom source nip >in ! ; variable chunk : chunk+=$ ( A -- ) chunk @ if chunk @ atom+=$ else drop then ; : chunk+=ref ( A -- ) chunk @ if chunk @ atom+=ref else drop then ; atom" ~~~DOC" constant main-documentation variable documentation-chunk main-documentation documentation-chunk ! : documentation ( -- A ) documentation-chunk @ ; : doc! ( back to documentation) 0 chunk ! ; : doc+=$ ( A -- ) documentation atom+=$ ; : .d{ ( -- ) postpone atom{ postpone doc+=$ ; immediate : .d| ( -- ) parse..| ; immediate : |.d ( -- ) postpone literal postpone doc+=$ ; immediate : .dcr atom-cr doc+=$ ; : doc+=ref ( A -- ) documentation atom+=ref ; : doc+=use ( A -- ) .d{ } doc+=$ .d{ } ; : doc+=def ( A -- ) .d{

} doc+=$ .d{ +≡
} ;

: feed ( read into current chunk )

    parse..| dup ?atom-cr+ escape doc+=$ atom-cr+ chunk+=$ ;


variable doc-base
atom" index" doc-base !

: |document-base:   parse-cr doc-base ! feed ;

variable title
atom" Untitled" title !

: |title:   parse-cr title ! feed ;

variable author
atom" Anonymous" author !

: |author:   parse-cr author ! feed ;

variable isbn
atom" 9999999999" isbn !

: |isbn:   parse-cr isbn ! feed ;

variable subject
atom" Article" subject !

: |subject:   parse-cr subject ! feed ;

variable doc-date
atom" Unknown" doc-date !

: |date:   parse-cr doc-date ! feed ;

variable description
atom" No description available." description !

: |description:   parse-cr description ! feed ;



linked-list out-files

: |file: ( add a new output file )
    parse-cr dup 1 out-files chain
    .d{ } doc+=$ .d{ } feed ;
: file-name@ ( file -- A )
    cell+ @ ;



variable slide-chapter
variable chapter-count
linked-list chapters

: chapter-name ( chp -- A )
    cell+ @ ;
: chapter-text ( chp -- A )
    cell+ @ means ;
: chapter-number ( chp -- n )
    2 cells + @ ;

atom" .html" constant .html
: chapter-filename ( chp -- A )
     chapter-number s>d <# # # # #s #> atom
     doc-base @ atom" _" atom+ swap .html atom+ atom+ ;


: chapter-finish   .d{ 

} ; : raw-chapter ( -- ) chapter-finish parse-cr chapter-count @ 1 chapter-count +! over 2 chapters chain dup documentation-chunk ! doc! .d| |.d slide-chapter @ if .d| |.d then .d| |.d dup doc+=$ .d{ } slide-chapter @ if .d{ } else .d{ } then .d{

} doc+=$ .d{

} feed ; : |chapter: false slide-chapter ! raw-chapter ; : |slide-chapter: true slide-chapter ! raw-chapter ; : |section: parse-cr .d{

} doc+=$ .d{

} feed ; : |page parse-cr .d{

} feed ; : |br parse-cr .d{
} feed ; : |$ ( paragraph ) .d{

} feed ; : |\ ( whole line) parse-cr atom-cr+ dup chunk+=$ escape doc+=$ feed ; : |b{ .d{ } feed ; : |}b .d{ } feed ; : |i{ .d{ } feed ; : |}i .d{ } feed ; : |u{ .d{ } feed ; : |}u .d{ } feed ; : |sup{ .d{ } feed ; : |}sup .d{ } feed ; : |sub{ .d{ } feed ; : |}sub .d{ } feed ; : |tt{ .d{ } feed ; : |}tt .d{ } feed ; : |code{ .d{

} feed ;

: |}code   .d{ 
} feed ; variable bullet-depth : bullet+ 1 bullet-depth +! bullet-depth @ 1 = if .d{

} then ; : bullet- -1 bullet-depth +! bullet-depth @ 0 = if .d{

} then ; : |{- bullet+ .d{

} bullet- feed ; : |TeX .d{ TEX} feed ; : |LaTeX .d{ LATEX} feed ; : |<-| .d{ ←} feed ; : |->| .d{ →} feed ; : |^| .d{ ↑} feed ; : |v| .d{ ↓} feed ; : |: ( add to a chunk ) parse-cr dup chunk ! doc+=def feed ; : |; ( documentation ) .d{

} doc! feed ; : |@ ( use a chunk ) parse-cr dup chunk+=ref doc+=use .dcr feed ; : |@@ ( use a chunk in documentation ) parse-cr means escape doc+=$ feed ; variable literate-mode : literate-setup depth 0<= if 0 then literate-mode ! ; literate-setup literate-mode @ 0 = constant running? literate-mode @ 1 = constant tangling? literate-mode @ 2 = constant weaving? weaving? tangling? or running? or assert atom" ~~~TOC" constant atom-toc : toc-filename doc-base @ atom" .html" atom+ ; : weave-toc-chapter ( chapter -- ) .d{

} chapter-name doc+=$ .d{

} .dcr ; : weave-toc atom-toc documentation-chunk ! doc! .d| Table of Contents

TABLE OF CONTENTS

|.d chapters @ begin dup while dup weave-toc-chapter ->next repeat drop .d{
} .dcr documentation means toc-filename file! ; atom" ~~~NCX" constant atom-ncx : ncx-filename ( -- A ) doc-base @ atom" .ncx" atom+ ; : weave-ncx-chapter ( chapter -- ) .d{ } dup chapter-name doc+=$ .d{ } ; : weave-ncx atom-ncx documentation-chunk ! doc! .d| |.d .d{ } title @ doc+=$ .d| me Table of Contents |.d chapters @ begin dup while dup weave-ncx-chapter ->next repeat drop .d{ } documentation means ncx-filename file! ; : cover-filename doc-base @ atom" _cover.bmp" atom+ ; variable image-width variable image-height variable image-data : image-data-size ( -- n ) image-width @ image-height @ * 4 * ; : image-pick-size ( w h -- ) image-height ! image-width ! ; : image-free-old image-data @ dup if free 0= assert else drop then ; : image-allocate image-data-size allocate 0= assert image-data ! ; : image-clear image-data @ image-data-size 0 fill ; : image-setup ( w h -- ) image-pick-size image-free-old image-allocate image-clear ; variable red variable green variable blue : rgb ( r g b -- ) blue ! green ! red ! ; : f>primary ( f -- n ) 255e f* f>s 0 max 255 min ; : rgbf ( rf gf bf -- ) f>primary f>primary f>primary rgb ; : black ( -- ) 0 0 0 rgb ; : white ( -- ) 255 255 255 rgb ; : gray ( n -- ) dup dup rgb ; : image-xy ( x y -- a ) image-width @ * + 4 * image-data @ + ; : plot ( x y -- ) image-xy red @ over c! green @ over 1+ c! blue @ over 2 + c! 0 swap 3 + c! ; variable bmp-file : bmp-begin ( A -- ) atom-string@ w/o bin create-file 0= assert bmp-file ! ; : bmp-end ( -- ) bmp-file @ close-file 0= assert ; : bmp-write ( $ -- ) bmp-file @ write-file 0= assert ; : bmp-byte ( b -- ) here c! here 1 bmp-write ; : bmp-word ( w -- ) dup 255 and bmp-byte 8 rshift 255 and bmp-byte ; : bmp-dword ( d -- ) dup 65535 and bmp-word 16 rshift 65535 and bmp-word ; 3 2 * 2 4 * + constant bmp-header-size 10 4 * constant dib-header-size : bmp-save ( A -- ) bmp-begin \ BMP header s" BM" bmp-write bmp-header-size dib-header-size + image-data-size + bmp-dword \ size of bmp file in bytes 0 bmp-word \ unused 0 bmp-word \ unused bmp-header-size dib-header-size + bmp-dword \ offset to start of bitmap image data \ DIB header dib-header-size bmp-dword \ size of header in bytes image-width @ bmp-dword \ width image-height @ bmp-dword \ height 1 bmp-word \ color planes 32 bmp-word \ bits per pixel 0 bmp-dword \ BI_RGB (uncompressed) image-data-size bmp-dword \ pixel data size 0 bmp-dword \ horizontal pixels per meter 0 bmp-dword \ vertical pixels per meter 0 bmp-dword \ colors in color palette 0 bmp-dword \ important colors in palette \ Image data image-data @ image-data-size bmp-write bmp-end ; fvariable xx fvariable yy : x ( -- f ) xx f@ ; : y ( -- f ) yy f@ ; variable xn variable yn fvariable aspect 1e aspect f! : haiku ( f -- ) image-height @ 0 do i yn ! i s>f 0.5e f+ image-width @ s>f aspect f@ f/ f/ yy f! image-width @ 0 do i xn ! i s>f 0.5e f+ image-width @ s>f f/ xx f! dup execute rgbf i j plot loop loop drop ; 0.0722e fconstant red-luminance 0.7152e fconstant green-luminance 0.2126e fconstant blue-luminance : luminance ( rf gf bf -- f ) blue-luminance f* fswap green-luminance f* f+ fswap red-luminance f* f+ ; create dither-table 1 , 49 , 13 , 61 , 4 , 52 , 16 , 64 , 33 , 17 , 45 , 29 , 36 , 20 , 48 , 32 , 9 , 57 , 5 , 53 , 12 , 60 , 8 , 56 , 41 , 25 , 37 , 21 , 44 , 28 , 40 , 24 , 3 , 51 , 15 , 63 , 2 , 50 , 14 , 62 , 35 , 19 , 47 , 31 , 34 , 18 , 46 , 30 , 11 , 59 , 7 , 55 , 10 , 58 , 6 , 54 , 43 , 27 , 39 , 23 , 42 , 26 , 38 , 22 , : dither-map ( x y -- f ) 8 mod 8 * swap 8 mod + cells dither-table + @ s>f 65e f/ 0.5e f- ; : dither ( -- f ) xn @ yn @ dither-map 7e f/ ; : 3dither-scale ( f -- f ) 7e f/ ; : 3dither ( rgb -- rgb' ) dither blue-luminance f/ 3dither-scale f+ frot dither green-luminance f/ 3dither-scale f+ frot dither red-luminance f/ 3dither-scale f+ frot ; fvariable gradient-scale : 3fg* ( f f f -- f f f ) gradient-scale f@ f* frot gradient-scale f@ f* frot gradient-scale f@ f* frot ; : gradient-invert 1e gradient-scale f@ f- gradient-scale f! ; : gradient1 1e x f- 0.3e f* y f+ 0.5e f+ 10e f** 0e fmax 1e fmin gradient-scale f! ; fvariable 3f+temp : 3f+ ( xyz abc -- x+a y+b z+c ) fswap 3f+temp f! frot f+ ( x y a z+c ) frot 3f+temp f@ f+ ( x a z+c y+b ) 3f+temp f! frot frot f+ ( z+c x+a ) 3f+temp f@ frot ( x+a y+b z+c ) ; : 4spire x x 23e f* fsin 2e f/ y fmax f/ fsin y x 23e f* fsin 2e f/ y fmax f/ fsin fover fover f/ fsin ; : scales-x' x 0.3e f- ; : scales-y' y 0.1e f+ ; : scales scales-x' scales-y' f* 40e f* fsin 1e scales-x' f- scales-y' f* 30e f* fsin f* scales-x' 1e scales-y' f- f* 20e f* fsin f* fdup scales-x' f/ fsin fdup scales-y' f/ fcos 1e x f- 1e y f- f+ f* ; : scales-4spire scales gradient1 3fg* 4spire gradient1 gradient-invert 3fg* 3f+ ; : scales-4spire-dithered scales-4spire 3dither ; : scales-4spire-gray scales-4spire luminance dither f+ fdup fdup ; : weave-cover 600 800 image-setup ['] scales-4spire-dithered haiku cover-filename bmp-save ; atom" ~~~OPF" constant atom-opf : opf-filename ( -- A ) doc-base @ atom" .opf" atom+ ; : opf-chapter ( A -- ) .d{ } .dcr ; : opf-chapter' ( A -- ) .d{ } .dcr ; : weave-opf atom-opf documentation-chunk ! doc! .d| |.d .d{ } title @ doc+=$ .d{ } .dcr .d{ en-us} .dcr .d{ } .dcr .d{ } isbn @ doc+=$ .d{ } .dcr .d{ } author @ doc+=$ .d{ } .dcr .d{ } author @ doc+=$ .d{ } .dcr .d{ } subject @ doc+=$ .d{ } .dcr .d{ } doc-date @ doc+=$ .d{ } .dcr .d{ } description @ doc+=$ .d{ } .dcr .d| } chapters @ begin dup while dup chapter-filename opf-chapter ->next repeat drop .d{ } .dcr .d{ } .d{ } chapters @ begin dup while dup chapter-filename opf-chapter' ->next repeat drop .d{ } .d| |.d documentation means opf-filename file! ; : weave-chapter ( chapter -- ) dup chapter-text swap chapter-filename file! ; : weave-chapters chapters @ begin dup while dup weave-chapter ->next repeat drop ; : weave ( -- ) weave-opf weave-ncx weave-cover weave-toc weave-chapters ; : tangle-file ( file -- ) file-name@ dup means swap file! ; : tangle out-files @ begin dup while dup tangle-file ->next repeat drop ; : run-filename ( -- A ) doc-base @ atom" _running.tmp" atom+ ; : run-cleanup run-filename atom-string@ delete-file drop ; : bye run-cleanup bye ; : run atom" *" means run-filename file!-tmp forth-wordlist 1 set-order forth-wordlist set-current include-file run-cleanup ; : |. ( exit literate mode ) chapter-finish weaving? if weave bye then tangling? if tangle bye then running? if run then ;