home *** CD-ROM | disk | FTP | other *** search
/ Dream 52 / Amiga_Dream_52.iso / RiscOS / APP / DEVS / FORTH / WIMPFO.ZIP / !WimpForth / windows < prev    next >
Text File  |  1996-03-21  |  19KB  |  715 lines
  1. \ window classes
  2. cr .( Loading generic wimp windows support...)
  3.  
  4. comment:
  5.     You will usually use WINDOWs by sending them a Start: message
  6.     passing the initial position. And you will close the window
  7.     by sending a Stop: message, what else.
  8.     GENERIC-WINDOWs are linked in a list so that the APPLICATION can
  9.     distribute the Wimp messages to the right GENERIC-WINDOW. (see pause')
  10.     WINDOWs are special GENERIC-WINDOWs which can respond to the
  11.     Wimp messages (On_*****: messages in WINDOW). You can do other
  12.     things with WINDOWs before opening them: SetTitleText: , Move: ,
  13.     GetSize: , Center: (get initial position so it will be centered
  14.     on the screen) and Print: .
  15.     Start: will Create: the WINDOW, then Open: it.
  16.     Create: sends a On_Init: message, then Move: and Build: itself.
  17.     Build: will create the memory structure for Wimp_CreateWindow.
  18.     When you say Stop: to a WINDOW, it Close: s and Delete: s itself.
  19.     The latter will invoke the newest On_Done: method.
  20.     So you may control the appearing and disappearing of WINDOWs in
  21.     several stages.
  22.       The basic work being done we can define a TEXT-WINDOW which
  23.     can display text. PutText: , PutCR: , BackSpace: , Cls: will
  24.     tell it what to display. You can control the cursor position.
  25.       The class EDIT-WINDOW can additionally gain the caret, although
  26.     I must admit that the handling is very incomplete.
  27.       CKey is a class to realise a circular key buffer. This could
  28.     be a place where keypresses to an application could be stored.
  29.       APPLICATIONs will distribute messages which arrive with them.
  30.     Keypresses to an object of CKey (PutKey:) , mouse clicks to the
  31.     appropriate WINDOW or ICONBAR-ICON (On_Click:)
  32.       In the end this file redefines the in/output deferred words
  33.     of the Forth system to work with windows.
  34. comment;
  35.  
  36. code Wimp_CreateWindow ( buf -- hndl )
  37.   mov r1, tos
  38.   swi " Wimp_CreateWindow"
  39.   mov tos, r0
  40. next c;
  41.  
  42. code Wimp_DeleteWindow ( buf -- )
  43.   mov r1, tos
  44.   swi " Wimp_DeleteWindow"
  45.   ldmfd sp !, { tos }
  46. next c;
  47.  
  48. code Wimp_OpenWindow ( buf -- )
  49.   mov r1, tos
  50.   swi " Wimp_OpenWindow"
  51.   ldmfd sp !, { tos }
  52. next c;
  53.  
  54. code Wimp_CloseWindow ( buf -- )
  55.   mov r1, tos
  56.   swi " Wimp_CloseWindow"
  57.   ldmfd sp !, { tos }
  58. next c;
  59.  
  60. code Wimp_RedrawWindow ( blk -- f )
  61.   mov r1, tos
  62.   swi " Wimp_RedrawWindow"
  63.   mov tos, r0
  64. next c;
  65.  
  66. code Wimp_UpdateWindow ( blk -- f )
  67.   mov r1, tos
  68.   swi " Wimp_UpdateWindow"
  69.   mov tos, r0
  70. next c;
  71.  
  72. code Wimp_GetRectangle ( buf -- f )
  73.   mov r1, tos
  74.   swi " Wimp_RedrawWindow"
  75.   mov tos, r0
  76. next c;
  77.  
  78. code OS_Plot ( y x type -- )
  79.   mov r0, tos
  80.   ldmfd sp !, { r1, r2, tos }
  81.   swi " OS_Plot"
  82. next c;
  83.  
  84. code Wimp_Initialise ( ^messages ^descr "TASK" osver -- thndl osver' )
  85.   mov r0, tos
  86.   ldmfd sp !, { r1, r2, r3 }
  87.   swi " Wimp_Initialise"
  88.   stmfd sp !, { r1 }
  89.   mov tos, r0
  90. next c;
  91.  
  92. code Wimp_CloseDown ( "TASK" taskhndl -- )
  93.   mov r0, tos
  94.   ldmfd sp !, { r1, tos }
  95.   swi " Wimp_CloseDown"
  96. next c;
  97.  
  98. code Wimp_Poll ( [^pollword] buf mask -- buf event )
  99.   mov r0, tos
  100.   tst r0, # &400000
  101.   ldmfd ne sp !, { r1, r3 }
  102.   ldmfd eq sp !, { r1 }
  103.   swi " Wimp_Poll"
  104.   mov tos, r0
  105.   stmfd sp !, { r1 }
  106. next c;
  107.  
  108. code Wimp_SetCaretPosition ( index hght y x ihndl whndl -- )
  109.   mov r0, tos
  110.   ldmfd sp !, { r1, r2, r3, r4, r5, tos }
  111.   swi " Wimp_SetCaretPosition"
  112. next c;
  113.  
  114. code Wimp_BlockCopy ( dymin dxmin symax sxmax symin sxmin whndl -- )
  115.   mov r0, tos
  116.   ldmfd sp !, { r1, r2, r3, r4, r5, r6, tos }
  117.   swi " Wimp_BlockCopy"
  118. next c;
  119.  
  120. code Wimp_ReportError ( ^title flags ^errorblock -- res )
  121.   mov r0, tos
  122.   ldmfd sp !, { r1, r2 }
  123.   swi " Wimp_ReportError"
  124.   mov tos, r1
  125. next c;
  126.  
  127. code Wimp_ForceRedraw ( ymax xmax ymin xmin whnd -- )
  128.   mov r0, tos
  129.   ldmfd sp !, { r1, r2, r3, r4, tos }
  130.   swi " Wimp_ForceRedraw"
  131. next c;
  132.  
  133. code Wimp_GetWindowState ( block -- )
  134.   mov r1, tos
  135.   swi " Wimp_GetWindowState"
  136.   ldmfd sp !, { tos }
  137. next c;
  138.  
  139. code Wimp_SendMessage ( Hicon Htask block eventcode -- )
  140.   mov r0, tos
  141.   ldmfd sp !, { r1, r2, r3, tos }
  142.   swi " Wimp_SendMessage"
  143. next c;
  144.  
  145. code -32* ( n -- n' )
  146.   mov tos, tos, lsl # 5
  147.   rsb tos, tos, # 0
  148. next c;
  149.  
  150. \ &1 constant WF_TitleBar
  151. &2 constant WF_Movable
  152. \ &4 constant WF_VScrollBar
  153. \ &8 constant WF_HScrollBar
  154. &10 constant WF_WimpRedraws
  155. &20 constant WF_Pane
  156. &40 constant WF_Outside
  157. \ &80 constant WF_NoBack/Close
  158. &100 constant WF_ScrollReqAR
  159. &200 constant WF_ScrollReq
  160. &400 constant WF_GCOLours
  161. &800 constant WF_NoBelow
  162. &1000 constant WF_HotKeys
  163. &2000 constant WF_StayOnScreen
  164. &4000 constant WF_IgnoreR
  165. &8000 constant WF_IgnoreL
  166. &10000 constant WF_Open?
  167. &20000 constant WF_OnTop?
  168. &40000 constant WF_FullSize?
  169. &80000 constant WF_ToggleSize?
  170. &100000 constant WF_InputFocus?
  171. &200000 constant WF_ForceOnScreen?
  172. &81000000 constant WF_BackIcon
  173. &82000000 constant WF_CloseIcon
  174. &84000000 constant WF_TitleBar
  175. &88000000 constant WF_ToggleSizeIcon
  176. &90000000 constant WF_VScrollBar
  177. &a0000000 constant WF_AdjSizeIcon
  178. &c0000000 constant WF_HScrollBar
  179.  
  180. 0 value windows-link
  181.  
  182. 0 value applobj
  183. 0 value applwin
  184. 0 value barpopup
  185. 0 value lastpopup
  186. 0 value outwindow
  187.  
  188. create block 44 allot
  189.  
  190. :class generic-window <super object <classpointer
  191. int hWnd
  192. :m ClassInit: ( -- )
  193.      0 to hWnd
  194.      here windows-link , to windows-link
  195.      self , ;m
  196. :m GetHandle: ( -- n )
  197.      hWnd ;m
  198. :m ZeroWindow: ( -- )
  199.      0 to hwnd ;m
  200. :m ~:         ( -- )
  201.      windows-link cell+ @ self =
  202.      if windows-link @ to windows-link
  203.      else windows-link
  204.        begin dup @ ?dup
  205.        while dup cell+ @ self =
  206.          if @ swap ! exitm then
  207.          nip
  208.        repeat
  209.      then ;m
  210. ;class
  211.  
  212. :class window <super generic-window <classpointer
  213. int xmin
  214. int ymin
  215. int xmax
  216. int ymax
  217. int xscroll
  218. int yscroll
  219. int behindhndl
  220. int wflags
  221. int ti/wacolour
  222. int sb/ticolour
  223. int waxmin
  224. int waymin
  225. int waxmax
  226. int waymax
  227. int TiIFlags
  228. int WBType
  229. int sprarea
  230. int minsize
  231. 12 bytes title
  232. int #icons
  233. int mypopup
  234. 64 bytes title"
  235. int ?open
  236.  
  237. : SetSize     { dx dy -- }
  238.      screen-size
  239.      cells 44 - dy ymin + min to ymax
  240.      2*    22 - dx xmin + min to xmax ;
  241. :m GetSize:   ( -- x y )
  242.      xmax xmin - ymax ymin - ;m
  243. : SetMinSize  ( x y -- )
  244.      16 lshift swap &ffff and or to minsize ;
  245. :m SetTitleText: ( ^str -- )
  246.      dup c@ 12 <
  247.      if   count >r title r@ move 0 title r> + c!
  248.           TiIFlags [ IF_IndData invert ] literal and to TiIFlags
  249.      else count tuck title" place
  250.           title 8 + ! title" 1+ title ! title cell+ on
  251.           TiIFlags IF_IndData or to TiIFlags 
  252.      then ;m
  253. : SetTiColour   ( fg bg sel -- )
  254.      &ff and 16 lshift sb/ticolour &ffff and or to sb/ticolour
  255.      &ff and 8 lshift swap &ff and or
  256.      ti/wacolour &ffff0000 and or      to ti/wacolour ;
  257. : SetWaColour   ( fg bg -- )
  258.      &ff and 8 lshift swap &ff and or 16 lshift
  259.      ti/wacolour &ffff and or          to ti/wacolour ;
  260. : SetWaSize   ( x y -- )
  261.      0 to waxmin      0 to waymax
  262.      negate to waymin   to waxmax ;
  263. : SetSBColour   ( in out -- )
  264.      &ff and swap &ff and 8 lshift or
  265.      sb/ticolour &ff0000 and or to sb/ticolour ;
  266. : SetScrollPos   ( x y -- )
  267.      to yscroll to xscroll ;
  268. : ChangeWFlags   ( n mask -- )
  269.      wflags and or to wflags ;
  270. :m ClassInit: ( -- )
  271.      ClassInit: super
  272.      640 320 SetSize
  273.      640 320 SetWaSize
  274.      0 0 SetMinSize
  275.      [ IF_Text                                nostack1
  276.        IF_Border    or
  277.        IF_HCentered or
  278.        IF_VCentered or
  279.        IF_FilledBG  or ] literal to TiIFlags
  280.      c" Window" SetTitleText: self
  281.      [ WF_Movable
  282.        WF_WimpRedraws or
  283.        WF_Outside     or
  284.        WF_ScrollReqAR or
  285.        WF_IgnoreR     or
  286.        WF_IgnoreL     or
  287.        WF_BackIcon    or
  288.        WF_CloseIcon   or
  289.        WF_VScrollBar  or
  290.        WF_AdjSizeIcon or
  291.        WF_HScrollBar  or
  292.        WF_ToggleSizeIcon or
  293.        WF_TitleBar    or ] literal 0 ChangeWFlags
  294.      1 to sprarea
  295.      Gray1 Gray3       SetSBColour
  296.      Black Gray2 Cream SetTiColour
  297.      Black White       SetWaColour
  298.      BT_1/Drag/2 to WBType
  299.      -1 to behindhndl 0 to #icons 
  300.      0 to mypopup ;m            nostack1
  301. :m Move:      { px py -- }
  302.      screen-size
  303.      cells 44 - py ymax ymin - + min to ymax py to ymin
  304.      2*    22 - px xmax xmin - + min to xmax px to xmin ;m
  305. :m Center:    ( -- x y )
  306.      screen-size cells ymax ymin - - 2/
  307.      swap 2* xmax xmin - - 2/ swap ;m
  308. :m Build:     ( ad -- ad' )
  309.      ^base cell+ ( hWnd ) over
  310.      88 move 88 + ;m
  311. :m On_Init:   ( -- )
  312.      ;m
  313. :m On_Done:   ( -- )
  314.      ;m
  315. :m Delete:    ( -- )
  316.      On_Done: [[ self ]]
  317.      hWnd block !
  318.      block Wimp_DeleteWindow
  319.      0 to hWnd ;m
  320. :m Create:    ( x y -- )
  321.      hWnd if Delete: self then
  322.      On_Init: [[ self ]]
  323.      Move: self
  324.      here 512 + aligned dup Build: [[ self ]] drop 
  325.      Wimp_CreateWindow to hWnd ;m
  326. :m Open:     ( -- )
  327.      hWnd 0= if xmin ymin Create: self then
  328.      ^base Wimp_OpenWindow
  329.      true to ?open ;m
  330. :m Close:     ( -- )
  331.      hWnd block !
  332.      block Wimp_CloseWindow
  333.      false to ?open ;m
  334. :m Start:     ( x y -- )
  335.      hwnd 0= if Create: self else Move: self then
  336.      Open: self ;m
  337. :m Stop:
  338.      Close: self
  339.      Delete: self ;m
  340. :m On_Open:  ( block -- )
  341.      cell+
  342.      lcount to xmin    lcount to ymin
  343.      lcount to xmax    lcount to ymax
  344.      lcount to xscroll lcount to yscroll
  345.      @      to behindhndl
  346.      Open: self ;m
  347. :m On_Close: ( block -- )
  348.      drop Close: self ;m
  349. :m On_Menu: ( block -- )
  350.     mypopup
  351.     if dup @ 64 - swap 4 + @ start: mypopup
  352.        mypopup to lastpopup
  353.     else drop then ;m
  354. :m On_Select: ( block -- )
  355.      drop ;m
  356. :m On_Adjust: ( block -- )
  357.      drop ;m
  358. :m On_Click: ( block -- )
  359.      dup 8 + c@
  360.      case 4 of On_Select: [[ self ]] endof
  361.           2 of   On_Menu: [[ self ]] endof
  362.           1 of On_Adjust: [[ self ]] endof
  363.        nip
  364.      endcase ;m
  365. :m &popup:   ( -- ^obj )
  366.      &> mypopup ;m
  367. :m Print:
  368.      ." Window@" ^base . ." Title: "
  369.      TiIFlags IF_IndData and
  370.      if title" count type
  371.      else title zcount type
  372.      then ;m
  373. ;class
  374.  
  375. : ErrorBox ( z"ErrorText -- res )
  376.     z" Message from WimpForth"
  377.     %10010011
  378.     rot Wimp_ReportError ;
  379.  
  380. :class text-window <super window
  381. int cols
  382. int rows
  383. int xcur
  384. int ycur
  385. int &thescreen
  386. int &endscreen
  387. int &title
  388. :m ClassInit: ( ^title cols rows -- )
  389.      ClassInit: super
  390.      0 WF_WimpRedraws invert ChangeWFlags
  391.      to rows to cols
  392.      cols 16* rows 5 lshift 2dup
  393.      SetSize SetWaSize
  394.      SetTitleText: self ;m
  395. :m On_Init:   ( -- )
  396.      rows cols * dup allocate abort" Not enough Heap!"
  397.      tuck to &thescreen 2dup blank
  398.      + to &endscreen ;m
  399. :m On_Done:   ( -- )
  400.      &thescreen free drop
  401.      0 to &thescreen 0 to &endscreen ;m
  402. 2variable plotpos
  403. code rectcalc ( cols block -- ad len #lines y x )
  404.   ldr r2, [ tos, # 16 ]
  405.   ldr r0, [ tos, # 24 ]
  406.   sub r2, r2, r0          \ r2=work_y0
  407.   ldr r0, [ tos, # 40 ]
  408.   sub r2, r2, r0
  409.   mov r3, r2, lsr # 5
  410.   ldmfd sp !, { r1 }
  411.   mul r3, r1, r3
  412.   and r2, r2, # &1f
  413.   add r0, r0, r2
  414.   sub r0, r0, # 2
  415.   ldr r1, [ tos, # 32 ]
  416.   sub r1, r0, r1
  417.   add r1, r1, # &1f
  418.   mov r1, r1, lsr # 5
  419.  
  420.   ldr r2, [ tos, # 4 ]
  421.   ldr r4, [ tos, # 20 ]
  422.   sub r2, r2, r4          \ r2=work_x0
  423.   ldr r4, [ tos, # 28 ]
  424.   sub r5, r4, r2
  425.   ldr r2, [ tos, # 36 ]
  426.   add r3, r3, r5, lsr # 4
  427.   and r5, r5, # &f
  428.   sub tos, r4, r5  
  429.   sub r2, r2, tos
  430.   add r2, r2, # &f
  431.   mov r2, r2, lsr # 4
  432.   stmfd sp !, { r0, r1, r2, r3 }
  433. next c;
  434. : DoRectangle
  435.     cols 2r@ drop
  436.     rectcalc ( ad len #lines y x )
  437.     plotpos 2! 0
  438.     ?do plotpos 2@ 188 OS_Plot     \ position on the screen
  439.       over &thescreen + dup &endscreen >= if drop leave then
  440.       over                         \ determine string to print
  441.       -trailing OS_WriteN          \ print it
  442.       -32 plotpos cell+ +!         \ bump screen pos
  443.       swap cols + swap             \ bump source
  444.     loop 2drop ;
  445. :m On_Redraw: ( block -- )
  446.      dup>r Wimp_RedrawWindow
  447.      begin while
  448.        DoRectangle
  449.        r@ Wimp_GetRectangle
  450.      repeat r>drop ;m
  451. : Update ( x1 y1 x2 y2 -- )       \ 1=bottom left
  452.     -32* block dup>r 16 + !       \ 2=top right
  453.     16* r@ 12 + ! 1+ -32* r@ 8 + !  16* r@ 4 + !
  454.     hWnd r@ !
  455.     r@ Wimp_UpdateWindow
  456.     begin while
  457.       DoRectangle
  458.       r@ Wimp_GetRectangle
  459.     repeat r>drop ;
  460. : Update+Clear ( x1 y1 x2 y2 -- )
  461.     -32* swap 16* 2swap 1+ -32* swap 16*
  462.     Hwnd Wimp_ForceRedraw ;
  463. : PutText ( ad len -- x y )
  464.      dup xcur + cols - dup 0>=
  465.      if - else drop then tuck
  466.      &thescreen ycur cols * + xcur + swap cmove
  467.      xcur ycur rot +to xcur ;
  468. : UpdateText ( x y -- )
  469.      xcur ycur Update ;
  470. :m PutText: ( ad len -- )
  471.      PutText UpdateText ;m
  472. : Scroll ( -- )
  473.        &thescreen cols + &thescreen rows 1- cols * dup>r cmove
  474.        &thescreen r> + cols blank
  475.        rows 1- -32* 0 -32 cols 16* rows -32* 0 hWnd Wimp_BlockCopy ;
  476. :m PutCR: ( -- )
  477.      0 to xcur
  478.      ycur 1+ rows =
  479.      if Scroll
  480.        0 rows 1- cols over Update+Clear 
  481.      else 1 +to ycur then ;m
  482. :m BackSpace: ( -- )
  483.      xcur if -1 +to xcur
  484.             xcur ycur xcur 1+ over Update+Clear
  485.           else 7 OS_WriteC then ;m
  486. :m Cls:       ( -- )
  487.      &thescreen cols rows * blank
  488.      0 rows 1- cols 0 Update+Clear
  489.      0 to xcur 0 to ycur ;m
  490. :m GetXY: ( -- x y )
  491.      xcur ycur ;m
  492. :m GotoXY: ( x y -- )
  493.      to ycur to xcur ;m
  494. :m GetColRow: ( -- col row )
  495.      cols rows ;m
  496. ;class
  497.  
  498. :class CKey <super object
  499. 132 bytes &keybuf
  500. :m ClassInit:
  501.      0 &keybuf w! ;m
  502. :m IsKey?: ( -- f )
  503.      &keybuf count swap c@ <> ;m
  504. : bump &keybuf + dup c@ 2 + &7f and swap c! ;
  505. :m PutKey: ( c -- )
  506.      &keybuf count swap c@ 2 - &7f and <>
  507.      if &keybuf count + 1+ w! 0 bump
  508.      else drop beep then ;m
  509. :m GetKey: ( -- c )
  510.      &keybuf count over c@ <>
  511.      if count + w@ 1 bump
  512.      else drop -1 then ;m
  513. :m On_Key: ( block -- )
  514.      24 + w@ PutKey: self ;m
  515. ;class
  516.  
  517. :class edit-window <super text-window <classpointer
  518. :m ClassInit: ( cols rows -- )
  519.      ClassInit: super
  520.      BT_Click to WBType ;m
  521. : SetCaret ( -- )
  522.     0 &02000020
  523.     ycur 1+ -32*  xcur 16*
  524.     -1 Hwnd
  525.     ?open if Wimp_SetCaretPosition
  526.           else 2drop 2drop 2drop then ;
  527. :m On_Select: ( block -- )
  528.      drop SetCaret ;m
  529. :m PutText:   ( ad len -- )
  530.      PutText ( SetCaret ) UpdateText ;m
  531. :m PutCR:     ( -- )
  532.      0 to xcur
  533.      ycur 1+ rows =
  534.      if Scroll else 1 +to ycur then
  535.      ( SetCaret )
  536.      0 ycur cols over Update+Clear ;m
  537. :m GetTheCaret: ( -- )
  538.      SetCaret ;m
  539. ;class
  540.  
  541. also classes
  542.  
  543. : getwin ( block -- block obj )
  544.     dup @ windows-link
  545.     begin ?dup
  546.     while 2dup cell+ @ GetHandle: [[ ]] =
  547.       if nip cell+ @ exit then
  548.       @
  549.     repeat abort" Window not found!" ;
  550. : zero-windows ( -- )
  551.     windows-link
  552.     begin ?dup
  553.     while dup cell+ @ ZeroWindow: [[ ]] @
  554.     repeat ;
  555. previous
  556.  
  557. 0 value OSVer
  558. 0 value TaskHndl
  559. variable pausecfa
  560.  
  561. : .platform
  562.     ." RISC OS " base @ >r decimal
  563.     OSVer 0 <# # # ascii . hold # #> type space r> base ! ;
  564.  
  565. s" WimpForth Window" drop 1- 80 25 edit-window mainwindow
  566. mainwindow dup to outwindow to applwin
  567.  
  568. :class iconbar-icon <super icon <classpointer
  569. :m ClassInit: ( ^str -- )
  570.      [ IF_Sprite IF_IndData or BT_Click or ] literal 0
  571.      ChangeIFlags: iconblock
  572.      SetText: iconblock
  573.      WH_IconBarR to hWnd
  574.      0 0 Move: iconblock
  575.      68 68 SetSize: iconblock
  576.      0 to hIcon ;m
  577. :m On_Click:  ( blk -- )
  578.      dup 8 + c@ 
  579.      case 2 of @ 64 - -96 start: barpopup
  580.                barpopup to lastpopup endof
  581.           4 of drop open: mainwindow
  582.                GetTheCaret: mainwindow endof
  583.      endcase ;m
  584. ;class
  585. " !wimpforth" drop 1- iconbar-icon ibicon
  586.  
  587. defer On_DataLoad ( ad len -- )
  588.  
  589. also classes
  590.  
  591. :class application <super object <classpointer
  592. CKey keybuf
  593. create PollBuf 256 allot
  594. : pause'
  595.     PollBuf 0 Wimp_Poll
  596.     case
  597.       1 of          On_Redraw: [[ getwin ]] endof
  598.       2 of            On_Open: [[ getwin ]] endof
  599.       8 of             On_Key:    applobj   endof
  600. \     12 of       On_GainCaret: [[ getwin ]] endof
  601. \     11 of       On_LoseCaret: [[ getwin ]] endof
  602.       9 of   On_MenuSelection:    applobj   endof
  603.       6 of           On_Click:    applobj   endof
  604.       3 of           On_Close: [[ getwin ]] endof
  605.      17 of        On_UMessage:    applobj   endof
  606.      18 of     On_UMessageRec:    applobj   endof
  607. \     19 of     On_UMessageAck: [[ getwin ]] endof
  608. \      7 of         On_DragBox: [[ getwin ]] endof
  609. \      4 of  On_PointerLeaving: [[ getwin ]] endof
  610. \      5 of On_PointerEntering: [[ getwin ]] endof
  611. \     10 of        On_ScrolReq: [[ getwin ]] endof
  612. \     13 of On_NonZeroPollWord: [[ getwin ]] endof
  613.      ( otherwise ) nip ( the pointer to block )
  614.     endcase ;
  615. :m ClassInit:
  616.      applobj abort" Only one Application!"
  617.      self to applobj ;m
  618. create d&dbuf 64 allot
  619. : message         ( block -- )
  620.     case dup 16 + @
  621.       0 of drop bye endof
  622.       3 of dup 44 + zcount d&dbuf place
  623.            dup 8 + @ over 12 + !
  624.            4 over 16 + !
  625.            0 swap dup 4 + @ swap 17 Wimp_SendMessage pause
  626.            d&dbuf count On_DataLoad endof
  627.       nip
  628.     endcase ;
  629. :m On_UMessageRec: ( block -- ) message  ;m
  630. :m On_UMessage:    ( block -- ) message  ;m
  631. :m Start:         ( -- )
  632.      block off
  633.      block z" WimpForth" &4b534154 310 Wimp_Initialise
  634.      to OSVer to TaskHndl
  635.      ['] pause' ['] pause dup @ pausecfa ! call!
  636.      ['] pause' is outpause
  637.      zero-windows
  638.      Create: ibicon ;m
  639. :m On_Click: ( block -- )
  640.      dup 12 + @ -2 =
  641.      if ibicon
  642.      else dup 12 + getwin nip then
  643.      On_Click: [[ ]] ;m
  644. :m On_MenuSelection: ( block -- )
  645.      Execute: lastpopup ;m
  646. :m On_Key: On_Key: keybuf ;m
  647. :m IsKey?: ( -- f ) IsKey?: keybuf ;m
  648. :m PutKey: ( c -- ) PutKey: keybuf ;m
  649. :m GetKey: ( -- c ) GetKey: keybuf ;m
  650. ;class previous
  651.  
  652. : wpushkey ( c -- )
  653.     PutKey: applobj ;
  654.  
  655. : w"pushkeys     ( a1 n1 -- )    \ push the characters of string a1,n1
  656.                 0max 127 min bounds
  657.                 ?do     i c@ pushkey
  658.                 loop    ;
  659.  
  660. : loadit s" fload " "pushkeys "to-pathend" "pushkeys 13 pushkey ;
  661. ' loadit is On_DataLoad
  662. ' wpushkey is pushkey
  663. ' w"pushkeys is "pushkeys
  664.  
  665. : wtype ( ad len -- )
  666.     PutText: outwindow outpause ;
  667. : wemit ( c -- )
  668.     dup bl <
  669.     if 
  670.       case
  671.         7 of 7 OS_WriteC endof
  672.         8 of BackSpace: outwindow endof
  673.        10 of PutCR: outwindow endof
  674.       endcase
  675.     else  sp@ 1 wtype drop then ;
  676. : wcr PutCR: outwindow ;
  677. : wcrtab PutCR: outwindow
  678.     tabing? 0= ?exit
  679.     first-line?
  680.     if left-margin indent + spaces false to first-line?
  681.     else left-margin spaces tab-margin spaces
  682.     then ;
  683. : wkey? pause IsKey?: applobj ;
  684. : wkey  begin pause IsKey?: applobj until
  685.         GetKey: applobj ;
  686. : wgetcolrow GetColRow: outwindow ;
  687. : wgetxy     GetXY: outwindow ;
  688. : wgotoxy    GotoXY: outwindow ;
  689. : wcol       wgetcolrow drop 1- min wgetxy drop - spaces ;
  690. : w?cr       wgetxy drop + wgetcolrow drop > if cr then ;
  691. : wcls       Cls: outwindow ;
  692.  
  693. : window-io     ( -- )                  \ reset to Forth IO words
  694.                 ['] wemit      is emit
  695.                 ['] wtype      is type
  696.                 ['] wcrtab       is cr
  697.                 ['] w?cr        is ?cr
  698.                 ['] wkey       is key
  699.                 ['] wkey?      is key?
  700.                 ['] wcls        is cls
  701. \                [']  cls        is page
  702.                 ['] wgotoxy     is gotoxy
  703.                 ['] wgetxy      is getxy
  704.                 ['] wgetcolrow  is getcolrow
  705.                 ['] wcol        is col ;
  706. forth-io-chain chain-add window-io
  707.  
  708. : exit-stuff ( -- )
  709.     bye-chain do-chain 0 &58454241 0 os_exit ;
  710. ' exit-stuff is bye
  711. : .leaving
  712.     ." Leaving..." cr ;
  713. : ExitWimp &4b534154 TaskHndl Wimp_CloseDown ;
  714. bye-chain chain-add .leaving
  715. bye-chain chain-add ExitWimp