home *** CD-ROM | disk | FTP | other *** search
/ Dream 52 / Amiga_Dream_52.iso / RiscOS / APP / DEVS / FORTH / WIMPFO.ZIP / !WimpForth / Controls < prev    next >
Text File  |  1996-03-21  |  9KB  |  300 lines
  1. \ Dialog box objects
  2. cr .( Loading generic wimp controls...)
  3.  
  4. comment:
  5.     DIALOG is a special WINDOW class which contains control icons,
  6.     such as DISPLAYFIELDs, TEXTLABELs, ACTIONBUTTONs, WRITABLEFIELDs,
  7.     OPTIONBUTTONs, RADIOBUTTONs, METERs and HSLIDERs.
  8.     The end of this file will demonstrate an overful example.
  9. comment;
  10.  
  11. create %actbut ," R5,3"
  12. create %dacbut ," R6,3"
  13. create %disfld ," R2"
  14. create %wrifld ," Ktar;Pptr_write"
  15. create %optbut ," soptoff,opton"
  16. create %radbut ," sradiooff,radioon"
  17. create %upaarr ," R5;sup,pup"
  18. create %dwnarr ," R5;sdown,pdown"
  19. create %slider ," R2"
  20. create %popupm ," R5;sgright,pgright"
  21. create %grpbox ," R4"
  22.  
  23. :class dialog <super window
  24. :m ClassInit: ( -- )
  25.      ClassInit: super
  26.      [ WF_Movable          nostack1
  27.        WF_WimpRedraws or
  28.        WF_Outside     or
  29.        WF_ScrollReqAR or
  30.        WF_IgnoreR     or
  31.        WF_IgnoreL     or
  32.        WF_TitleBar    or ] literal 0 ChangeWFlags
  33.      Black Gray1 SetWaColour
  34.      BT_Ignore to WBType ;m
  35. 0 value #ESG
  36. : BeginESG ( -- )
  37.     1 +to #ESG #ESG negate nostack1 ;
  38. : EndESG   ( -- ) drop nostack1 ;
  39. : BeginIcons
  40.     0 to #icons 0 to #ESG ;
  41. : EndIcons ;
  42. :m NewIcon:   ( -- n )
  43.      #icons 1 +to #icons ;m
  44. ;class nostack1
  45.  
  46. |class actionbutton <super generic-icon
  47. :m ClassInit: ( -- )
  48.      ClassInit: super
  49.      [ IF_Text             nostack1
  50.        IF_VCentered    or
  51.        IF_HCentered    or
  52.        IF_IndData      or
  53.        BT_Click        or
  54.        IF_Border       or
  55.        IF_FilledBG     or ] literal 0 ChangeIFlags: self
  56.      Black Gray1 SetColour: self
  57.      %actbut 1+ IconData cell+ ! ;m
  58. :m SetText:   ( ^str -- )
  59.      dup SetIndirText
  60.      c@ 1+ 16* 10 + 52 SetSize: self ;m
  61. :m Start:     ( window -- )
  62.      NewIcon: [[ ]] drop ;m
  63. ;class nostack1
  64.  
  65. :class defactionbutton <super actionbutton
  66. :m ClassInit: ( -- )
  67.      ClassInit: super
  68.      %dacbut 1+ IconData cell+ ! ;m
  69. :m SetText:   ( ^str -- )
  70.      dup SetIndirText
  71.      c@ 1+ 16* 18 + 68 SetSize: self ;m
  72. ;class
  73.  
  74. :class textlabel <super generic-icon
  75. :m ClassInit:  ( -- )
  76.      [ IF_VCentered IF_IndData or IF_Text or ] literal
  77.      &ff000000 ChangeIFlags: self
  78.      Black White SetColour: self
  79.      0 52 SetSize: self ;m
  80. :m Start:     ( window -- )
  81.      NewIcon: [[ ]] drop ;m
  82. :m SetText:    ( ^str -- )
  83.      dup c@ 16* 52 SetSize: self
  84.      SetText: super ;m
  85. ;class
  86.  
  87. :class rtextlabel <super textlabel
  88. :m Move:     ( x y -- )
  89.      dup ymax ymin - + to ymax to ymin
  90.      dup xmax xmin - - to xmin to xmax ;m
  91. ;class
  92.  
  93. :class displayfield <super textlabel
  94. :m ClassInit:  ( -- )
  95.      ClassInit: super
  96.      [ IF_VCentered     nostack1
  97.        IF_IndData   or
  98.        IF_HCentered or
  99.        IF_Border    or
  100.        IF_Text      or ] literal &ff000000 ChangeIFlags: self
  101.      %disfld 1+ IconData cell+ ! ;m
  102. :m SetLength:  ( n -- )
  103.      16* 12 + xmin + to xmax ;m
  104. :m SetText:    ( ^str -- )
  105.      SetIndirText ;m
  106. ;class
  107.  
  108. :class writablefield <super displayfield
  109. :m ClassInit:  ( -- )
  110.      ClassInit: super
  111.      [ BT_Caret IF_FilledBG or ] literal -1 ChangeIFlags: self
  112.      %wrifld 1+ IconData cell+ ! ;m
  113. :m SetBuffer:  ( ad len -- )
  114.      IconData 8 + ! IconData ! ;m
  115. :m SetText:    ( ^str -- )
  116.      count IconData @ ?dup
  117.      if swap 1+ cmove
  118.      else true abort" Set Buffer for writable Field first"
  119.      then ;m
  120. :m Read:       ( -- ^str )
  121.      IconData @ ;m
  122. ;class
  123.  
  124. :class optionbutton <super generic-icon
  125. :m ClassInit: ( -- )
  126.      ClassInit: super
  127.      [ IF_Text             nostack1
  128.        IF_Sprite       or
  129.        IF_VCentered    or
  130.        IF_IndData      or
  131.        BT_1/Drag       or ] literal &ff000000 ChangeIFlags: self
  132.        Black Gray1 SetColour: self
  133.      %optbut 1+ IconData cell+ ! ;m
  134. :m SetText:   ( ^str -- )
  135.      dup SetIndirText
  136.      c@ 1+ 16* 44 + 44 SetSize: self ;m
  137. :m Start:     ( window -- )
  138.      NewIcon: [[ ]] drop ;m
  139. ;class nostack1
  140.  
  141. :class radiobutton <super optionbutton
  142. :m ClassInit: ( -- )
  143.      ClassInit: super
  144.      %radbut 1+ IconData cell+ ! ;m
  145. :m SetText:   ( esg ^str -- esg' )
  146.      SetText: super
  147.      dup abs dup 16 lshift rot
  148.        0< IF_Sel/Inv and or IFlags or to IFlags ;m
  149. ;class
  150. comment:
  151. :class upadjarrow <super generic-icon
  152. :m ClassInit: ( x y -- )
  153.      ClassInit: super
  154.      xmax xmin - 32 + 44 SetSize: self
  155.      [ IF_Text             nostack1
  156.        IF_Sprite       or
  157.        IF_VCentered    or
  158.        IF_IndData      or
  159.        BT_ClickAR      or ] literal &ff000000 ChangeIFlags: self
  160.      %upaarr 1+ IconData cell+ ! ;m
  161. ;class nostack1
  162.  
  163. :class downadjarrow <super generic-icon
  164. :m ClassInit: ( x y -- )
  165.      ClassInit: super
  166.      xmax xmin - 32 + 44 SetSize: self
  167.      [ IF_Text             nostack1
  168.        IF_Sprite       or
  169.        IF_VCentered    or
  170.        IF_IndData      or
  171.        BT_ClickAR      or ] literal &ff000000 ChangeIFlags: self
  172.      %dwnarr 1+ IconData cell+ ! ;m
  173. ;class nostack1
  174. comment;
  175.  
  176. :class meter <super generic-icon
  177. generic-icon well
  178. generic-icon backg
  179. int maxval
  180. int xsize
  181. int Wobj
  182. int Ihndl
  183. :m ClassInit: ( -- )
  184.      ClassInit: super
  185.      [ IF_Text IF_IndData or IF_Border or BT_Click or ] literal
  186.      &ff000000 ChangeIFlags: well
  187.      temp$ %slider 1+ 1 SetIconData: well
  188.      Black Gray1 SetColour: well
  189.      [ IF_Sprite IF_FilledBG or BT_Click or ] literal &ff000000 ChangeIFlags: backg
  190.      White White SetColour: backg
  191.      [ IF_Sprite IF_FilledBG or BT_Click or ] literal 0 ChangeIFlags: self
  192.      Gray5 Gray5 SetColour: self ;m
  193. :m SetMax/Len: ( max n -- )
  194.      dup  16 SetSize: backg
  195.      dup 20 + 36 SetSize: well
  196.      to xsize to maxval ;m
  197. :m Write:      ( n -- )
  198.      maxval min 0max
  199.      xsize maxval */ 16 SetSize: self
  200.      GetHandle: [[ Wobj ]] ?dup if
  201.        dup>r pad ! Ihndl pad cell+ !
  202.        pad Wimp_GetIconState
  203.        pad Wimp_DeleteIcon
  204.        r@ pad cell+ tuck !
  205.          xmax over 12 + dup @ >r !
  206.          Ihndl Wimp_CreateIcon drop
  207.        ymin 16 + xmax r@ max ymin xmax r> min
  208.          r> Wimp_ForceRedraw pause
  209.      then ;m
  210. :m Move:       ( x y -- )
  211.      2dup Move: well
  212.      swap 10 + swap 12 + 2dup
  213.      Move: backg Move: super ;m
  214. :m Build:      ( -- )
  215.      Build: well
  216.      Build: backg
  217.      Build: super ;m
  218. :m Start:     ( window -- )
  219.      dup NewIcon: [[ ]] drop
  220.      dup NewIcon: [[ ]] drop
  221.      dup to Wobj
  222.      NewIcon: [[ ]] to ihndl ;m
  223. ;class
  224.  
  225. :class hslider <super meter
  226. :m Read:       ( -- n )
  227.      xmax xmin - maxval xsize */ ;m
  228. :m On_Select:   ( block -- )
  229.      @ GetHandle: [[ Wobj ]] pad dup>r !
  230.      r@ Wimp_GetWindowState
  231.      r> 4 + @ - xmin - maxval * xsize 2/ + xsize /
  232.      Write: self ;m
  233. ;class
  234.  
  235. \s An Example
  236.  
  237. :Object fd <super dialog
  238. writablefield Text
  239. actionbutton OKBut
  240. radiobutton DefRB
  241. radiobutton OtherRB
  242. hslider slid
  243. displayfield disp
  244. 20 bytes writebuffer
  245. :m On_Init:    ( -- )
  246.      500 350  2dup  SetSize: self  SetWaSize: self  \ my own size
  247.      c" My Dialog"  SetTitleText: self              \ my title text
  248.      BeginIcons
  249.        self               Start: Text               \ register with dialog window
  250.        16             SetLength: Text               \ maximal width (otherwise 0)
  251.        32 -55              Move: Text               \ position in window
  252.        writebuffer 17 SetBuffer: Text               \ the buffer
  253.        c" Martin"       SetText: Text               \ initial text
  254.        self      Start: OKBut
  255.        c" OK"  SetText: OKBut
  256.        32 -115    Move: OKBut
  257.        80 55   SetSize: OKBut                       \ make it bigger than standard
  258.        BeginESG
  259.          self          Start: DefRB
  260.          c" Default" SetText: DefRB
  261.          32 -159 Move: DefRB
  262.          self        Start: OtherRB
  263.          c" Other" SetText: OtherRB
  264.          32 -203 Move: OtherRB
  265.        EndESG
  266.        self Start: slid  32 -255 Move: slid
  267.        16 400 SetMax/Len: slid                      \ scale the meter
  268.        6 Write: slid                                \ initial value
  269.        self Start: disp  32 -310 Move: disp
  270.        16 SetLength: disp                           \ maximal width (otherwise 0)
  271.        c" Das ist Text" SetText: disp
  272.      EndIcons ;m
  273. :m On_Select:  ( block -- )                         \ select was pressed on
  274.      dup 16 + @                                      \ the dialog
  275.      case
  276.        1 of drop Stop: self endof                   \ on button?
  277.        4 6 of-range drop On_Select: slid endof      \ or on slider?
  278.        .                                            \ on other
  279.      endcase ;m
  280. :m On_Adjust:  ( block -- )                         \ adjust was pressed
  281.      ." Adjust?" 16 + @ . ;m
  282. :m On_Done:    ( -- res )                           \ window is about to be
  283.      Read: Text zcount type space Read: slid . ;m    \ deleted
  284. :m Build:     ( ad -- ad' )                         \ Build: the window header
  285.      Build: super                                   \ and then all icons
  286.      Build: Text
  287.      Build: OKBut
  288.      Build: DefRB
  289.      Build: OtherRB
  290.      Build: slid
  291.      Build: disp ;m
  292. ;Object
  293.  
  294. popup fdp "Hot Dialog"                              \ context sensitive menu
  295.   menuitem "Quit" stop: fd ;                         
  296. fdp &Popup: fd !                                    \ adhered to the dialog
  297.  
  298. 400 400 start: fd                                   \ start the thing
  299.  
  300.