home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / forth / compiler / fpc / source / tmenu.seq < prev    next >
Encoding:
Text File  |  1989-11-02  |  10.2 KB  |  275 lines
  1. \ TMENU.SEQ     Visual menu selection tool for TCOM     by Tom Zimmer
  2.  
  3. FORTH DECIMAL >FORTH ONLY FORTH ALSO COMPILER ALSO DEFINITIONS
  4.  
  5.                                         \ n1 = number of menu entries
  6.                                         \ a1 = address filled by MENULINE"
  7.                                         \ n2 = running total of menu length
  8. : newmenubar    ( n1 | <name> --- a1 )  \ make a menubar of <name>
  9.                 create
  10.                 here-d 1+ swap dup c,-d 2* allot-d ;
  11.  
  12. ' newmenubar alias newmenu
  13. ' drop       alias endmenu
  14.  
  15.                                         \ a1 = address of count of strings
  16.                                         \ n1 = current running total of lines
  17.                                         \ string" = menu text line to display
  18.                                         \ function = functio name for line
  19.                                         \ n1+1 = resulting running total
  20.                                         \ compile a new menu line
  21. : menuline"     ( a1 | string" function --- a1 )
  22.                 ,"                              \ lay in string
  23.                 ' >resaddr @ over !-d 2+ ;      \ lay function in
  24.  
  25. ONLY FORTH ALSO COMPILER ALSO HTARGET ALSO TARGET ALSO DEFINITIONS
  26. FORTH DECIMAL TARGET >LIBRARY       \ A Library file
  27.  
  28. defer doother           \ what to do with other keys
  29.  
  30. 0 value mline           \ display menu starting line
  31. 0 value mcolumn         \ display menu starting column
  32.  
  33. 0 value mcol            \ current menu column
  34. 0 value mrow            \ Item to hilight in column
  35. 0 value menukey
  36. 0 value menubar         \ return address of the menubar itself
  37. 0 value menulist        \ return address of the menus on bar
  38.  
  39. HTARGET DEFINITIONS TARGET
  40.  
  41. : >strings      ( a1 n1 -- a2 n1 )
  42.                 tuck 2* + swap ;
  43.  
  44. : domfunc       ( col row --- )         \ perform function for menu item
  45.                 >r 2* menulist + @ 1+ r> 1- 0max 2* + @
  46.                 cursor-on
  47.                 execute
  48.                 cursor-off ;
  49.  
  50. : mhoriz   ( a1 --- )              \ display a horizontal menu
  51.                 mcolumn mline at
  52.                 0 swap count >strings 0
  53.                 do      i mcol =
  54.                         if      nip #out @ swap >rev
  55.                         else    >bold
  56.                         then    space count 2dup type +
  57.                 loop    drop
  58.                 >bold cols #out @ - spaces >norm
  59.                 ( col --- ) cursor-on 1+ mline at ;
  60.  
  61. : mvert     ( a1 --- )              \ display a vertical menu
  62.                 >r menubar count 2* + dup >r
  63.                 mcol 0max 0
  64.                 ?do     count +
  65.                 loop    r> -            \ calculate the column of vert menu
  66.                 mcolumn +
  67.                 mline 1+                \ row number of vertical menu
  68.                 r@ count 2* + c@     \ width
  69.                 >r over r> + 1+ over r@ c@ + menubox
  70.                 0 0     \ default cursor location if not in any menu row.
  71.                 r> count >strings 0
  72.                 do      tx 1+ ty i + at
  73.                         i 1+ mrow =
  74.                         if      >r 2drop
  75.                                 #out @ #line @ r>
  76.                                 >rev
  77.                         then    count 2dup type + >norm
  78.                 loop    drop at ;
  79.  
  80.                                 \ find the first uppercase letter in string
  81. : ucscan        ( a1 --- c1 )   \ a1 is a counted string, c1 = char or NULL
  82.                 0 swap count bounds
  83.                 ?do     i c@ 'A' 'Z' between
  84.                         i c@ '0' '9' between or
  85.                         if      drop i c@ leave
  86.                         then
  87.                 loop    ;
  88.  
  89. : 1st-rowchar   ( --- c1 )              \ return first char of row message
  90.                 mcol 2* menulist + @    \ addr of menu list
  91.                 count >strings
  92.                 mrow 1- min 0MAX 0
  93.                 ?do     count +         \ step to next item
  94.                 loop    1+ c@ ;
  95.  
  96. : ?menu_name    ( a1 -- a1 f1 )
  97.                 dup ucscan dup 0= or bl or menukey bl or = ;
  98.  
  99. : ?menuname     ( c1 f1 -- c1 f2 )
  100.                 0 menubar count >strings 0
  101.                 do      ?menu_name
  102.                         if      over =: mcol
  103.                                 1 =: mrow
  104.                                 2swap 2drop 0 0
  105.                                 2swap
  106.                                 leave
  107.                         else    swap 1+ swap
  108.                                 count +
  109.                         then
  110.                 loop    2drop ;
  111.  
  112. : ?found_name   ( a1 -- a1 f1 )
  113.                 dup ucscan bl or menukey bl or = menukey bl <> and ;
  114.  
  115. : ?name_inmenu  ( c1 f1 -- c1 f2 )
  116.                 mcol  2* menulist + @         \ addr of menu list
  117.                 1 swap count >strings 0
  118.                 ?do     ?found_name
  119.                         if      drop =: mrow
  120.                                 13              \ 13 = return
  121.                                 false           \ process command
  122.                                 2swap
  123.                                 leave
  124.                         else    swap 1+ swap    \ bump count
  125.                                 count +         \ step to next item
  126.                         then
  127.                 loop    2drop ;
  128.  
  129. : ?menukey      ( c1 f1 --- c1 f2 )     \ sets mcol  or mrow
  130.                 over =: menukey
  131.                 mrow 0=                         \ are we on the menubar
  132.                 if      menukey 13 =            \ did we press <enter>
  133.                         if      1 =: mrow       \ pop down menu
  134.                                 drop true
  135.                         else    ?menuname       \ else search for menu name
  136.                         then
  137.                 else    ?name_inmenu    \ search for name in current menu
  138.                 then    ;
  139.  
  140. : ?mup          ( c1 -- c1 )
  141.                 dup 200 <> ?exit        \ UP
  142.                 0=
  143.                 mrow 1- 0MAX =: mrow
  144.                 begin   1st-rowchar 196 =       \ skip over horizontal line
  145.                         mrow 0> and
  146.                 while   mrow 1- 0MAX =: mrow
  147.                 repeat  ;
  148.  
  149. : ?mdown        ( c1 -- c1 )
  150.                 dup 208 <> ?exit        \ DOWN
  151.                 0=
  152.                 mrow 1+
  153.                 mcol  2* menulist + @ c@ dup>r min =: mrow
  154.                 begin   1st-rowchar 196 =       \ skip over horizontal line
  155.                         mrow r@ < and
  156.                 while   mrow 1+ r@ min =: mrow
  157.                 repeat  r> drop ;
  158.  
  159. : ?mhome        ( c1 -- c1 )
  160.                 dup 199 <> ?exit        \ HOME
  161.                 0=
  162.                 mrow 0=                 \ if 0 then
  163.                 if      0 =: mcol       \ home to left
  164.                 else    0 =: mrow
  165.                 then    ;
  166.  
  167. : ?mend         ( c1 -- c1 )
  168.                 dup 207 <> ?exit        \ END
  169.                 0= mcol  2* menulist + @ c@ =: mrow ;
  170.  
  171. : ?mright       ( c1 -- c1 )
  172.                 dup 205 =               \ RIGHT
  173.                 over bl = or 0= ?exit
  174.                 0=
  175.                 recoverscr
  176.                 mcol menubar c@ 1- =
  177.                 if      0
  178.                 else    mcol   1+ menubar c@ 1- min
  179.                 then    =: mcol
  180.                 mrow 1 min =: mrow ;
  181.  
  182. : ?mleft        ( c1 -- c1 )
  183.                 dup 203 <> ?exit        \ LEFT
  184.                 0=
  185.                 recoverscr
  186.                 mcol 0=
  187.                 if      menubar c@ 1-
  188.                 else    mcol   1- 0MAX
  189.                 then    =: mcol
  190.                 mrow 1 min =: mrow ;
  191.  
  192. : ?domkey       ( c1 --- c1 | 0 )
  193.                 ?mhome  ?mend   ?mright ?mleft  ?mup    ?mdown
  194.                 dup 13 = if 0= then ;
  195.  
  196. TARGET DEFINITIONS
  197.  
  198. : .menubar      ( --- )
  199.                 menubar mhoriz ;
  200.  
  201. : .menu         ( --- )
  202.                 menulist mcol 2* + @ mvert ;
  203.  
  204. : showmenus     ( --- )
  205.                 mrow 0>
  206.                 if      .menubar .menu
  207.                 else    recoverscr .menubar
  208.                 then    ;
  209.  
  210. : menu          ( --- )
  211.                 savecursor              \ save cursor position
  212.                 cursor-off
  213.                 0 =: mrow
  214.                 savescr                 \ Save original screen
  215.                 mcol >r
  216.                 -1 =: mcol .menubar     \ display menubar without hilite
  217.                 r> =: mcol
  218.                 savescr                 \ save it again
  219.                 begin   showmenus
  220.                         key dup 27 <>           \ while not ESC
  221.                            over 13 <> and       \ and not carraige return
  222.                         ?menukey                \ or menu key
  223.                         if      ?domkey
  224.                         then    ?dup
  225.                 until
  226.                 restscr restscr                 \ Recover original screen
  227.                 restcursor
  228.                 dup     13 =                    \ is char a Carraige Return
  229.                 if      drop
  230.                         mcol mrow domfunc       \ then do the function
  231.                 else    dup 27  =
  232.                         if      drop            \ discard if ESC
  233.                         else    doother         \ else process OTHER key
  234.                         then
  235.                 then    ;
  236.  
  237. FORTH TARGET >TARGET
  238.  
  239. \s      ******** HERE IS AN EXAMPLE OF A SIMPLE SET OF MENUS ********
  240.  
  241. : adummy        ( -- )
  242.                 beep ;
  243.  
  244. 4 newmenu dfile$
  245.         menuline"  1 Dummy    F1 " adummy
  246.         menuline"  2 Dummy    F1 " adummy
  247.         menuline"  3 Dummy    F1 " adummy
  248.         menuline"  4 Dummy    F1 " adummy
  249. endmenu
  250.  
  251. 3 newmenu dedit$
  252.         menuline"  5 Dummy    F1 " adummy
  253.         menuline"  6 Dummy    F1 " adummy
  254.         menuline"  7 Dummy    F1 " adummy
  255. endmenu
  256.  
  257. 2 newmenubar mymenubar
  258. ," File  " ," Edit "
  259. endmenu
  260.  
  261. create mymenulist    dfile$ ,-d dedit$ ,-d
  262.  
  263. : myother       ( c1 -- )
  264.                 drop ;
  265.  
  266. : menuinit      ( -- )          \ MENUINIT must be called before calling
  267.                                 \ MENU to startup menu use.
  268. \               vmode.set       \ you must use direct video mode for menus
  269.                 ['] myother is doother
  270.                 mymenubar   =: menubar
  271.                 mymenulist  =: menulist ;
  272.  
  273.  
  274.  
  275.