\ ********************************************************************** \ \ NeWS Forth HyperTIES storyboard interpreter stuff \ Don Hopkins \ \ ********************************************************************** requires string-equals.f requires sh.f requires clink.f requires ctypes.f requires fcall.f \ link in the formatter library "" ties.out clink decimal : undef bl word find if >name 1+ 255 swap c! else ." ? " count type ." ?" cr then ; \ Kludge to punt the last cold hook, which calls gtty (lose!) ' (cold-hook >body token@ is cold-hook \ rename last definition of "(cold-hook" to "Xcold-hook"! undef (cold-hook \ ditto with "bye" (does stty too!) undef bye \ ditto with "lineedit" (does stty too!) undef lineedit \ version that doesn't bomb forth by messing with error-output (w/ psexec) : safe-interpret-do-undefined count type ." ?" cr quit ; defer quote-compile ' "compile is quote-compile \ patch quote-compile "compile (interpret patch noop (restore-output files-mode patch noop (error-output files-mode : fix-output ['] noop ['] error-output (is ['] noop ['] restore-output (is ; : get-centry: ( #args #returns -- entry ) ( Input stream: name ) bl word ( #args #returns str ) dup cname "copy ( #args #returns str ) find 0= if interpret-do-undefined then ( #args #returns cfa ) makebody ( #args ip ) here -rot ( entry-point #args ip ) swap make-c-entry ( entry-point ) ; \ save forth regiters upon cold boot, for use by c to forth callbacks later. : (cold-hook (cold-hook init-fregs ; ' (cold-hook is cold-hook : cstring, ( string -- ) count tuck here swap cmove ( len ) allot 0 c, align ; : c~ compile (" ascii ~ parse over over + 0 swap c! 1+ ",s compile 1+ ; immediate struct ( font_metrics ) addr fm_name int fm_size int fm_ascent int fm_descent int fm_height addr fm_widths addr fm_next constant /font_metrics \ read a string delimited by delim from from the input string, \ returning its address (same each time!) : cword ( delim -- addr ) word count over + 0 swap c! ; \ compile a null terminated string delimited by delim from the input \ stream into the dictionary, returning its address : cword, ( delim -- addr ) here swap word cstring, ; : fl _flush_PS ; : find-font ( size name --- font / 0 ) _find_metrics ret ?dup if swap drop swap drop else ." Can't find font " cscount type space . cr 0 then ; : set-font ( size name --- ) 2dup _font_name ! _font_size ! find-font ?dup if _font ! _on_page @ if _setup_font then then ; \ convert a counted string to a null terminated string : nullterm ( str -- cstr ) count over + 0 swap c! ; create buf 256 allot : to-buf count tuck buf swap cmove buf + 0 swap c! ; : .font \ name size bl word to-buf bl word literal? if buf set-font else ." Bad font point size: " count type cr then ; 256 stack: saved-fonts : setup-font ( font --- ) _font ! _setup_font ; : start-font ( font --- ) _font @ saved-fonts push setup-font ; : end-font saved-fonts pop _font ! _setup_font ; : .button-font \ name size bl word to-buf bl word literal? if buf find-font _button_font ! \ kludge to get buttons to come out right _default_font @ fm_height @ _button_font @ fm_height ! _default_font @ fm_descent @ _button_font @ fm_descent ! else ." Bad font point size: " count type cr then ; : .default-font \ name size bl word to-buf bl word literal? if buf find-font _default_font ! else ." Bad font point size: " count type cr then ; : .definition-font \ name size bl word to-buf bl word literal? if buf find-font _definition_font ! else ." Bad font point size: " count type cr then ; : .controls-font \ name size bl word to-buf bl word literal? if buf find-font _controls_font ! else ." Bad font point size: " count type cr then ; : .nl _new_line ; : .sp _space ; : .line-space bl word literal? if _line_space ! else ." Bad .line-space number: " count type cr then ; : .spaces bl word literal? if 0 ?do .sp loop else ." Bad number of .spaces: " count type cr then ; : .lines bl word literal? if 0 ?do .nl loop else ." Bad number of .lines: " count type cr then ; : .para-indent bl word literal? if _para_indent ! else ." Bad .para-indent number: " count type cr then ; : .indent _para_indent @ 0 ?do .sp loop ; : .para .nl .nl .indent ; : .top-margin bl word literal? if _top_margin ! _init_margins else ." Bad .top-margin number: " count type cr then ; : .bottom-margin bl word literal? if _bottom_margin ! _init_margins else ." Bad .bottom-margin number: " count type cr then ; : .left-margin bl word literal? if _left_margin ! _init_margins else ." Bad .left-margin number: " count type cr then ; : .right-margin bl word literal? if _right_margin ! _init_margins else ." Bad .right-margin number: " count type cr then ; 256 stack: margin-stack : .save-margins _left_margin @ margin-stack push _right_margin @ margin-stack push _top_margin @ margin-stack push _bottom_margin @ margin-stack push ; : .restore-margins margin-stack pop _left_margin ! margin-stack pop _right_margin ! margin-stack pop _top_margin ! margin-stack pop _bottom_margin ! _init_margins ; : .home _home ; : .page _start_page ; : show-word buf _show_string drop _cur_x @ _left @ <> if .sp then ; : .quote \ word bl word to-buf show-word ; create line-buf 256 allot line-buf 'tib ! 255 80 npatch (query : read-line ( --- str ) begin newline word dup c@ 0= while drop tib 255 expect span @ #tib ! >in off repeat ; : .quote-line \ word read-line to-buf show-word ; : show-string buf _show_string drop ; : .line \ line read-line to-buf show-string .nl ; alias .left .line : center-string buf _center_string drop ; : .center \ line read-line to-buf center-string ; : right-string buf _right_string drop ; : .right \ line read-line to-buf right-string ; : .picture \ name read-line to-buf buf _paint_picture drop ; : .page-target here 1+ _page_bg_name ! read-line ", 0 c, here 1+ _page_bg_ref ! read-line ", 0 c, ; : .definition-target here 1+ _definition_bg_name ! read-line ", 0 c, here 1+ _definition_bg_ref ! read-line ", 0 c, ; : .controls-target here 1+ _controls_bg_name ! read-line ", 0 c, here 1+ _controls_bg_ref ! read-line ", 0 c, ; : .full-entry-target here 1+ _full_entry_button_name ! read-line ", 0 c, here 1+ _full_entry_button_ref ! read-line ", 0 c, ; : .default-button-name here 1+ _button_name ! read-line ", 0 c, ; : fit-rect ( w h --- ) swap _fit_image 2drop ; : .rect \ w h bl word literal? if bl word literal? if fit-rect else ." Bad rect height: " count type cr then else ." Bad rect width: " count type cr then ; : move-to ( x y --- ) swap _move_cur 2drop ; : .moveto \ x y bl word literal? if bl word literal? if move-to else ." Bad y pos: " count type cr then else ." Bad x pos: " count type cr then ; : rmove-to ( x y --- ) swap _rmove_cur 2drop ; : .rmoveto \ x y bl word literal? if bl word literal? if rmove-to else ." Bad y pos: " count type cr then else ." Bad x pos: " count type cr then ; 64 constant /tabs create tab-stops /tabs /l* allot : .def-tab \ tab# pos bl word literal? if bl word literal? if swap dup /tabs < over 0< or if /n* tab-stops + ! else ." Not a valid tab#: " . cr drop then else ." Bad tab#: " count type cr then else ." Bad x pos: " count type cr then ; : .tab \ tab# bl word literal? if /n* tab-stops + @ _left_margin @ + _cur_x ! else ." Bad .tab pos: " count type cr then ; : .overstrike _overstrike ; : make-button ( -- ) show-word buf _button_name @ _stamp_target 2drop ; : .button \ word read-line to-buf _button_font @ start-font make-button end-font ; : .buttonline \ word .button .nl ; alias .buttonl .buttonline : .~ \ word~ ascii ~ word to-buf _button_font @ start-font make-button end-font ; : .ref \ word bl word to-buf _button_font @ start-font make-button end-font ; : .rem \ remark read-line drop ; : .free-stamps _free_stamps fl ; create target-name 256 allot : .target \ name ref read-line count tuck target-name swap cmove target-name + 0 swap c! read-line to-buf buf target-name _stamp_target 2drop ; variable interpreter-pops 0 interpreter-pops ! : pop-interpreter 1 interpreter-pops +! ; : poppable-interpret begin ?stack interpreter-pops @ if -1 interpreter-pops +! 0 dup else bl word more? then while quote-compile repeat drop ; ' poppable-interpret is interpret variable ignore-until ignore-until off variable doing-contents? doing-contents? off variable doing-definition? doing-definition? off variable doing-controls? doing-controls? off variable found-contents? found-contents? off : "process ( str --- ) ignore-until @ if dup count lower dup ignore-until @ vfind if \ str acf drop ignore-until off else \ str str 2drop unnest then then \ true if word begins with . and length > 1 dup 1+ c@ ascii . = dup if drop dup c@ 1 <> then ( .command? ) if dup count lower "compile else to-buf show-word then ; : .forth ['] "compile ['] quote-compile (is ignore-until off ; : .process ['] "process ['] quote-compile (is ; \ c callback into forth to pass a string to the forth interpreter for execution : forth_exec ( --- ) dup begin count 0= until 'tib @ >r >in @ >r #tib @ >r over - 1- #tib ! 'tib ! >in off interpret r> #tib ! r> >in ! r> 'tib ! ; \ make c callable function and patch it into the the int (*forth_exec)() 1 0 get-centry: forth_exec _forth_exec ! \ c callback into forth to bomb and warm start forth : forth-bomb cr ." Bombing to Forth!" cr .forth warm ; : (warm-hook (warm-hook fix-output ; ' (warm-hook is warm-hook \ make c callable function and patch it into the the int (*forth_bomb)() 0 0 get-centry: forth-bomb _forth_bomb token! : .f fl ; variable started started off : interact lineedit sun .forth ; : .init started @ 0= if started on _init_fmt fix-output then .f ; : .pile-pos \ x y bl word literal? if bl word literal? if _win_y ! _win_x ! else ." Bad y pos: " count type cr then else ." Bad x pos: " count type cr then ; : .pile-size \ width height bl word literal? if bl word literal? if _win_height ! _win_width ! else ." Bad height: " count type cr then else ." Bad width: " count type cr then ; 32 constant /piles 128 constant /path create piles /piles /n* allot piles /piles /n* erase variable this-pile : .new-pile \ class _win_height @ _win_width @ _win_y @ _win_x @ bl word to-buf buf _new_pile drop 2drop 2drop ret this-pile ! .f ; : .zap _zap_pages ; : .end _end_page .f .forth ; : start-contents _start_page .process ; : start-controls _start_controls .process ; : start-definition _start_definition .process ; : >voc >body @ up@ + ; create double-quote ascii " c, 0 c, create title-buf 256 allot : .title read-line to-buf buf title-buf 255 cmove .process ; variable this-entry : execute-storyboard buf c@ dup 1+ buf c! buf + 1+ ascii . swap c! \ append . doing-definition? @ if ascii d else doing-controls? @ if ascii c else ascii a then then buf c@ dup 1+ buf c! buf + 1+ c! bl buf dup c@ + 1+ c! buf find if ." ker" execute ." chunk" cr else .process buf c@ 2- buf c! "load then ; : .do read-line 0 over count + c! 1+ buf swap _lookup_document drop drop ret dup this-entry ! if execute-storyboard else ." Duh, huh?" cr then .end .f ; : use-linked-pile ( cstr --- ) _use_linked_pile drop ret this-pile ! ; : use-contents-pile c~ ContentsPileID~ use-linked-pile ; : use-definition-pile c~ DefinitionPileID~ use-linked-pile ; : use-controls-pile c~ ControlsPileID~ use-linked-pile ; : init-contents use-contents-pile _zap_pages ; : init-definition use-definition-pile _zap_pages c~ Definition~ _set_title drop ; : init-controls use-controls-pile _zap_pages ; : .start-definition ignore-until off doing-contents? off doing-definition? on doing-controls? off found-contents? off _definition_font @ start-font ; : .end-definition end-font use-contents-pile .f ; : .define .start-definition .do .end-definition ; : .start-article ignore-until off doing-contents? on doing-definition? off doing-controls? off found-contents? off use-contents-pile _default_font @ start-font ; : .end-article end-font found-contents? @ if init-definition use-contents-pile then .f ; : .do-article .start-article .do .end-article ; : .energize ." \ Energizing ..." cr ignore-until off doing-contents? off doing-definition? off doing-controls? on found-contents? on _controls_font @ start-font .do doing-controls? off end-font use-contents-pile .f ; : this-path this-pile @ /n* piles + dup @ ?dup if swap drop else here dup rot ! here , /path /n* allot then ; : path-top this-path ?empty if -1 else this-path top@ then ; : remember-article ( ent --- ) path-top 0= if this-path pop drop then dup path-top = if this-path pop drop then this-path push ; : .articulate .do-article found-contents? @ if this-entry @ ?dup if \ is there a current entry? this-entry @ remember-article then then ; : .index .do-article this-entry @ ?dup if \ is there a current entry? this-path ?empty if this-entry @ else 0 then remember-article then ; : .return this-path sdepth 1 > if this-path pop drop path-top this-entry ! buf this-entry @ _counted_entry_name 2drop ignore-until off doing-contents? on doing-definition? off doing-controls? off use-contents-pile _default_font @ start-font execute-storyboard end-font init-definition use-contents-pile .end then ; : .go ." \ Materializing ..." cr lineedit this-path clearstack found-contents? on .articulate ; \ Sticking the voc addr of one of these search pattern vocabularies \ into ignore-until will cause "process to ignore words until the next \ occurance of a word in that vocabulary, which it then looks up in \ the normal vocabulary search order, and executes. (it does not \ execute the word in the search pattern voc.) vocabulary definition-voc vocabulary contents-voc vocabulary controls-voc also definition-voc definitions create .definition create .description previous definitions also contents-voc definitions create .contents create .content previous definitions also controls-voc definitions create .controls previous definitions : .synonyms doing-definition? @ if \ skip till .definition or .description, and execute it ['] definition-voc >voc ignore-until ! else doing-contents? @ if \ skip till .contents or .content, and execute it ['] contents-voc >voc ignore-until ! else doing-controls? @ if \ skip till .controls, and execute it ['] controls-voc >voc ignore-until ! then then then ; alias .synonym .synonyms : .definition doing-definition? @ if init-definition title-buf _set_title drop start-definition else doing-contents? @ if \ skip till .contents or .content, and execute it ['] contents-voc >voc ignore-until ! else doing-controls? @ if \ skip till .controls, and execute it ['] controls-voc >voc ignore-until ! then then then ; alias .description .definition : .contents found-contents? on doing-contents? @ if init-contents title-buf _set_title drop start-contents else doing-definition? @ if .nl _controls_font @ start-font _full_entry_button_ref @ _show_string _full_entry_button_name @ _stamp_target 2drop end-font pop-interpreter then then ; alias .content .contents : .controls doing-controls? @ if init-controls start-controls then ; : .notes pop-interpreter ; : .bye bye ; : .setup-controls-pile _setup_controls_pile ; : .setup-definition-pile _setup_definition_pile ; : .setup-contents-pile _setup_contents_pile ; : .pile \ n bl word literal? if _use_pile this-pile ! else ." Bad PileID: " count type cr then ; : .name-pile \ name bl word to-buf buf _name_pile drop ; : .use-linked-pile \ name bl word to-buf buf _use_linked_pile drop ret this-pile ! ; : .use-parent-pile _use_parent_pile ret this-pile ! ; : .local \ name bl word to-buf buf _def_local drop ; : .global \ name bl word to-buf buf _def_global drop ; : ps-emit ( c --- ) _write_ps_char drop ; : ps-type ( addr len --- ) swap _write_ps_text 2drop ; : ps-text ( cstring --- ) _send_ps_text drop ; : ps-string ( cstring --- ) _send_ps_string drop ; : ps-int ( int --- ) _send_ps_int drop ; \ ************************************************************************ \ \ Storyboard Compiler Stuff \ \ ************************************************************************ : .compile-article ." : " bl word count type cr _recording on .articulate _recording off ." found-contents? " cr found-contents? @ if ." on" else ." off" then cr ." _on_page off" cr ." .f" cr ." ;" cr ; : .compile-definition ." : " bl word count type cr _recording on .define _recording off ." found-contents? " found-contents? @ if ." on" else ." off" then cr ." _on_page off" cr ." .f" cr ." ;" cr ; : .compile-controls ." : " bl word count type cr found-contents? on _recording on .energize _recording off ." found-contents off" cr ." _on_page off" cr ." .f" cr ." ;" cr ; \ ************************************************************************ \ \ Display Opcodes \ \ ************************************************************************ \ set_pile_name(string name) : .SN ( title --- ) _actually_set_pile_name drop ; \ use_font(string name, int size) : .UF ( size name --- ) _actually_use_font 2drop ; \ put_picture(name, x, y); : .PP ( y x name --- ) _actually_put_picture 2drop drop ; \ put_target(name, ref, x, y, w, h); : .PT ( h w y x ref name --- ) _actually_put_target 2drop 2drop 2drop ; \ put_string(string s, int x, int y) : .PS ( y x s --- ) _actually_put_string 2drop drop ; \ start page : .SP _actually_start_page ; \ end page : .EP _actually_end_page ; \ start line : .SL _actually_start_line ; \ end line : .EL 0 0 c~ ~ 0 0 0 0 ( len pos name h w y x --- ) _actually_end_line 2drop 2drop 2drop drop ; \ zap pages : .ZP _actually_zap_pages ; \ int use_linked_pile(name) : .ULP _actually_use_linked_pile drop ret this-pile ! ; \ int use_parent_pile() : .UPP _actually_use_parent_pile ret this-pile ! ;