home *** CD-ROM | disk | FTP | other *** search
/ Dream 52 / Amiga_Dream_52.iso / RiscOS / APP / DEVS / FORTH / WIMPFO.ZIP / !WimpForth / menus < prev    next >
Text File  |  1996-03-21  |  5KB  |  196 lines
  1. \ Wimp Popup Menus
  2. cr .( Loading generic wimp menus support...)
  3.  
  4. comment:
  5.    This file contains the code for defining a menu structure as it is
  6.    done in "extend" and "winsee".
  7.    During creation POPUP will be informed about the different MENUITEMS
  8.    which will be linked into a list using the messages SetNext: and
  9.    LastEntry: . When a menu button is pressed on the application
  10.    window or iconbar icon the POPUP is sent a Start: message.
  11.    The POPUP in return will do its preaction if it has one,
  12.    Build: itself and then call Wimp_CreateMenu.
  13.    The building action consists of constructing the menu structure
  14.    and sending a Build: message to the list of MENUITEMS. They in
  15.    turn will append their structure to the menu structure and return.
  16.    Some extra handling is involved with SUBMENU and SUBWINDOW,
  17.    see the Build: method for class MENUITEM.
  18.    The use of PreMenu: is shown in "extend".
  19. comment;
  20.  
  21. 0 value BuildMenu
  22. 0 value &menuworkspace
  23.  
  24. code Wimp_GetPointerInfo
  25.   mov r1, tos
  26.   swi " Wimp_GetPointerInfo"
  27.   ldmfd sp !, { tos }
  28. next c;
  29.  
  30. :class PopUp <super object <classpointer
  31. int first
  32. int last
  33. int title
  34. int colour
  35. int preaction
  36. :m FirstEntry: ( -- n )
  37.      first ;m
  38. :m LastEntry: ( -- n )
  39.      first if last else self then ;m
  40. :m SetNext:  ( n -- )
  41.      first 0= if dup to first then
  42.      to last ;m
  43. :m SetWAColour:  ( fg bg -- )
  44.      8 lshift + 16 lshift colour &ffff and or to colour ;m
  45. :m SetTiColour:  ( fg bg -- )
  46.      8 lshift + colour &ffff0000 and or to colour ;m
  47. :m ClassInit:  ( -- )
  48.      self to BuildMenu
  49.      0 to first  0 to last
  50.      0 to title  0 to preaction
  51.      Black Gray2 SetTiColour: self
  52.      Black White SetWaColour: self
  53.      here ,"text" to title ;m
  54. :m Build:     ( ad -- ad' )
  55.      >r title count r@ 8 + ! r@ cell+ off r@ !
  56.      IF_IndData OrMFlags: first
  57.      colour r@ 12 + !
  58.      0 r@ 24 + !
  59.      title c@
  60.      r@ 28 + Build: first
  61.      swap 1+ 4 lshift r@ 16 + !  44 r> 20 + !  ;m
  62. : OpenMenu
  63.      preaction if preaction execute then
  64.      &menuworkspace Build: self drop
  65.      &menuworkspace 2 cells- 2@
  66.      &menuworkspace Wimp_CreateMenu
  67.      &menuworkspace 28 - off ;
  68. :m Start:     ( x y -- )
  69.      here 7000 + aligned to &menuworkspace
  70.      dup 0<
  71.      if negate +height: first then
  72.      swap &menuworkspace 2 cells- 2!
  73.      OpenMenu ;m
  74. :m Execute:   ( block -- )
  75.      &menuworkspace 28 - @ 0=
  76.      if &menuworkspace 28 - dup Wimp_GetPointerInfo
  77.        8 + c@ 1 and >r
  78.      else false >r then
  79.      lcount Execute: first
  80.      r> if OpenMenu then ;m
  81. :m SetPreaction: ( cfa -- )
  82.      to preaction ;m
  83. ;class
  84.  
  85. : PreMenu:
  86.     align here SetPreaction: BuildMenu
  87.     docol call, !csp ] ;
  88.  
  89. :class menuitems <super object <classpointer
  90. int next
  91. :m ClassInit: ( -- )
  92.      LastEntry: BuildMenu dup to next
  93.      self SetNext: next drop
  94.      0 to next ;m
  95. :m +Height:    ( n -- n' )
  96.      44 + next if +Height: next then ;m
  97. :m SetNext:    ( n -- )
  98.      dup to next
  99.      SetNext: BuildMenu ;m
  100. :m Execute: ( block nr -- )
  101.      next if Execute: next else 2drop then ;m
  102. ;class
  103.  
  104. |class menuitem <super menuitems
  105. int mytext
  106. int mflags
  107. int iflags
  108. int ?submenu
  109. :m ClassInit: ( -- )
  110.      here ,"text" to mytext
  111.      ClassInit: super
  112.      0 to mflags
  113.      -1 to ?submenu
  114.      [ IF_Text IF_FilledBG or IF_IndData or &07000000 or ] literal
  115.      to iflags
  116.      docol call, !csp ] ;m
  117. :m OrMFlags:  ( n -- )
  118.      mflags or to mflags ;m
  119. :m HaveSub:   ( n -- )
  120.      to ?submenu ;m
  121. :m Build:     ( mw ad -- mw' ad' )
  122.      swap mytext c@ max swap
  123.      mflags   over !  cell+
  124.      ?submenu &8000 here between if tuck then
  125.      ?submenu over !  cell+
  126.      iflags   over !  cell+
  127.      >r mytext count r@ 8 + ! r@ cell+ off r@ !
  128.      r> 12 +
  129.      next
  130.      if Build: next
  131.      else mflags &80 or over 24 - !
  132.      then
  133.      ?submenu &8000 here between if Build: ?submenu then ;m
  134. : doit ( block -- ) drop mytext count + 1+ aligned execute ;
  135. :m Execute: ( block nr -- )
  136.      ?dup if 1- Execute: next
  137.      else ?submenu 1+
  138.        if   dup @ 1+ if Execute: ?submenu else drop then
  139.        else doit
  140.        then
  141.      then ;m
  142. :m Check: ( f -- )
  143.      0<> negate mflags &fffffffe and or to mflags ;m
  144. :m Checked?: ( -- f )
  145.      mflags 1 and 0<> ;m
  146. :m Enable: ( f -- )
  147.      0= &400000 and iflags &ffdfffff and or to iflags ;m
  148. ;class
  149.  
  150. :class :menuitem <super menuitem
  151. :m ClassInit:
  152.      ClassInit: super
  153.      hide ;m
  154. ;class
  155.  
  156. |class submenu <super popup <classpointer
  157. menuitem parentline
  158. int ParentMenu
  159. :m ClassInit: ( -- ) postpone [
  160.      BuildMenu to ParentMenu
  161.      self HaveSub: parentline
  162.      ClassInit: Super
  163.      self to BuildMenu ;m
  164. :m SetNext:    ( n -- )
  165.      self BuildMenu =
  166.      if SetNext: super
  167.      else SetNext: parentline then ;m
  168. :m Unsubmenu: ( -- )
  169.      ParentMenu to BuildMenu ;m
  170. :m Build:     ( ad1 mw ad2 -- mw ad' )
  171.      dup>r rot ! r>
  172.      Build: super ;m
  173. ;class
  174.  
  175. : endsubmenu ( -- )
  176.     Unsubmenu: BuildMenu ;
  177.  
  178. |class subwindow <super menuitem
  179. :m ClassInit:  ( -- )
  180.      ClassInit: super
  181.      postpone ;
  182.      ' execute to ?submenu ;m
  183. :m Build:      ( ad -- ad' )
  184.      ?submenu >r
  185.      0 0 Create: ?submenu GetHandle: ?submenu to ?submenu
  186.      Build: super
  187.      r> to ?submenu ;m
  188. ;class
  189.  
  190. |class menuseparator <super menuitems
  191. :m Build:     ( ad -- ad' )
  192.      2 over 24 - dup>r c@ or r> c!
  193.      next if Build: next then ;m
  194. :m +Height:   ( n -- n' )
  195.      +Height: super 18 - ;m
  196. ;class