home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / forth / compiler / fpc / source / menus.seq < prev    next >
Text File  |  1990-07-23  |  14KB  |  368 lines
  1. \ SEDMENU.SEQ   Visual menu selection tool for SED      by Tom Zimmer
  2.  
  3. only forth also definitions hidden also
  4.  
  5. 1 value default-mline   defer mline     ' default-mline   is mline
  6. 0 value default-mcolumn defer mcolumn   ' default-mcolumn is mcolumn
  7.  
  8. 0    value mcol         \ current menu column
  9. 0    value mrow         \ Item to hilight in column
  10. 0    value menukey
  11.  
  12. defer doother   ' drop is doother       \ Throw away any key we don't want
  13.                                         \ for now at least.
  14.  
  15. defer mbutton ' noop is mbutton         \ menu button function
  16.  
  17.                                         \ n1 = number of menu entries
  18.                                         \ a1 = address to be filled by ENDMENU
  19.                                         \ n2 = running total of menu length
  20. : newmenu       ( name --- a1 n2 ) \ creates "name" the menu name
  21.                 create
  22.                 xhere paragraph + dup xdpseg ! xseg @ - , xdp off
  23.                 here 0 c, 0 ;    \ build start of menu string list
  24.  
  25.                                         \ a1 = address to be filled by ENDMENU
  26.                                         \ n1 = running total of menu length
  27. : newmenubar    ( name --- a1 n1 )      \ make a new menubar of "name"
  28.                 create here 0 c, 0 ;
  29.  
  30. : endmenu       ( a1 n1 --- )
  31.                 swap c! ;
  32.  
  33. : +,"           ( n1 | string --- n1+1 )
  34.                 1+ ,"  ;                \ lay in string
  35.  
  36.                                         \ a1 = address of count of strings
  37.                                         \ n1 = current running total of lines
  38.                                         \ string" = menu text line to display
  39.                                         \ function = functio name for line
  40.                                         \ n1+1 = resulting running total
  41.                                         \ compile a new menu line
  42. : menuline"     ( a1 n1 | string" function --- n1+1 )
  43.                 +,"                     \ lay in string
  44.                 ' xhere !L              \ lay function in LIST space
  45.                 2 xdp +! ;              \ bump LIST space
  46.  
  47. defer makefile  ' noop is makefile
  48. defer editfile  ' noop is editfile
  49. defer dolisting ' noop is dolisting
  50. defer dofhelp   ' noop is dofhelp
  51.  
  52. headerless
  53.  
  54. : mbye          ( --- )
  55.                 0 rows 1- at bye ;
  56.  
  57. : ledit_restore ( --- )
  58. \u <.stat>      statv @ if <.stat> then
  59.                 off> mcol
  60.                 0 rows 1- at
  61.                 editbuf off
  62.                 off> ecursor
  63.                 off> stripping_bl's
  64.                 0 =: ex rows 1- =: ey ;
  65.  
  66. : editafile     ( --- )
  67.                 editfile cr ledit_restore ;
  68.  
  69. : makeafile     ( --- )
  70.                 makefile cr ledit_restore ;
  71.  
  72. : openfile      ( --- )
  73.                 #tib @ >in ! file
  74. \u <.stat>      statv @ if <.stat> then
  75.                 ;
  76.  
  77. : fhelp         ( --- )
  78.                 dofhelp ledit_restore ;
  79.  
  80. : do-dos        ( --- )
  81.                 clearmem
  82.                 savescr                 \ save the screen
  83.                 dark
  84.                 cr >attrib1 ."  Type EXIT to return to F-PC. " >norm cr
  85.                 here dup off $sys dup 2 =
  86.                 if      ."  Couldn't find COMMAND.COM     Press a key"
  87.                         key drop
  88.                 then    8 =
  89.                 if      ." Not enough memory to run DOS   Press a key"
  90.                         key drop
  91.                 then
  92.                 restscr ;
  93.  
  94. \ Patch functions into the line editor
  95.  
  96. >keys1
  97.  
  98. ' do-dos        is  dolf        \ Invoke DOS                    Ctrl-J
  99. ' fhelp         187 lkey!       \ Invoke HELP                   F1
  100. ' makeafile     177 lkey!       \ Make a new file               Alt-N
  101. ' openfile      152 lkey!       \ Open a file                   Alt-O
  102. ' editafile     146 lkey!       \ Edit a file                   Alt-E
  103. ' dolisting     153 lkey!       \ print current file            Alt-P
  104.  
  105. >keys2
  106.  
  107. newmenu dfile$
  108.         menuline"  Help me learn F-PC     F1 " fhelp
  109.         menuline" ────────────────────────── " noop
  110.         menuline"  New  file           Alt-N " makeafile
  111.         menuline"  Open file           Alt-O " openfile
  112.         menuline"  Edit  current file  Alt-E " editafile
  113.         menuline"  Print current file  Alt-P " dolisting
  114.         menuline" ────────────────────────── " noop
  115.         menuline"  Dos Shell      Ctrl-Enter " do-dos
  116.         menuline" ────────────────────────── " noop
  117.         menuline"  Quit & return to DOS      "  mbye
  118. endmenu
  119.  
  120. newmenu dumy$
  121.         menuline"  Help me learn F-PC     F1 " fhelp
  122. endmenu
  123.  
  124. 0 value defsave
  125.  
  126. headers
  127.  
  128. newmenubar default-bar
  129. +," File  "
  130. +,"  ── Press ENTER and use - to walk Up & Down the menu ── "
  131. endmenu
  132. create default-list    dfile$ , dumy$ ,
  133.  
  134. default-bar   value menubar
  135. default-list  value menulist
  136.  
  137. headerless
  138.  
  139. : dofunc        ( col row --- )         \ perform function for menu item
  140.                 1- 0MAX 2* >r 2* menulist + @ @ +XSEG r> @L
  141.                 nosetcur off
  142.                 cursor-on
  143.                 execute
  144.                 cursor-off
  145.                 nosetcur on ;
  146.  
  147. : .horizontal   ( a1 --- )              \ display a horizontal menu
  148.                 mcolumn mline at
  149.                 0 swap count 0
  150.                 do      i mcol =
  151.                         if      nip @> #out swap >attrib4
  152.                         else    >attrib1
  153.                         then    space count 2dup type +
  154.                 loop    drop
  155.                 >attrib1 COLS @> #out - spaces >norm
  156.                 ( col --- ) ?DOSIO
  157.                 if      cursor-on 1+ mline at  else drop  then    ;
  158.  
  159. : .vertical     ( a1 --- )              \ display a vertical menu
  160.                 >r menubar 1+ dup >r mcol 0
  161.                 ?do     count +
  162.                 loop    r> -    \ calculate the column of vertical menu
  163.                 mcolumn +
  164.                 mline 1+        \ row number of vertical menu
  165.                 r@ 1+ c@        \ width
  166.                 >r over r> + 1+ over r@ c@ + menubox
  167.                 0 0     \ default cursor location if not in any menu row.
  168.                 r> count 0
  169.                 do      tx 1+ ty ( 1+ ) i +
  170.                         ?DOSIO
  171.                         if      at
  172.                         else    =: #line =: #out
  173.                         then
  174.                         i 1+ mrow =
  175.                         if      >r 2drop
  176.                                 @> #out @> #line r>
  177.                                 >rev
  178.                         then    count 2dup type + >norm
  179.                 loop    drop at ;
  180.  
  181. : .menubar      ( --- )
  182.                 ?doingmac ?exit
  183.                 menubar .horizontal ;
  184.  
  185. : .menu         ( --- )
  186.                 ?doingmac ?exit
  187.                 menulist mcol  2* + @ 2+ .vertical ;
  188.  
  189. headers
  190.  
  191. : showmenus     ( --- )
  192.                 mrow 0>
  193.                 if      .menubar .menu
  194.                 else    recoverscr .menubar
  195.                 then    ;
  196.  
  197. headerless
  198.  
  199.                                 \ find the first uppercase letter in string
  200. : ucscan        ( a1 --- c1 )   \ a1 is a counted string, c1 = char or NULL
  201.                 0 swap count bounds
  202.                 ?do     i c@ 'A' 'Z' between
  203.                         i c@ '0' '9' between or
  204.                         if      drop i c@ leave
  205.                         then
  206.                 loop    ;
  207.  
  208. : 1st-rowchar   ( --- c1 )              \ return first char of row message
  209.                 mcol  2* menulist + @ 2+ \ addr of menu list
  210.                 count mrow 1- min 0MAX 0
  211.                 ?do     count +         \ step to next item
  212.                 loop    1+ c@ ;
  213.  
  214. : ?menukey      ( c1 f1 --- c1 f2 )     \ sets mcol  or mrow
  215.                 over =: menukey
  216.                 mrow 0=                         \ are we on the menubar
  217.                 if      menukey 13 =            \ did we press <enter>
  218.                         if      1 =: mrow       \ pop down menu
  219.                                 drop true
  220.                         else                    \ else search for menu name
  221.                                 0 menubar count 0
  222.                                 do      dup ucscan dup 0= or
  223.                                         bl or menukey bl or =
  224.                                         \ dup 1+ c@ bl or menukey bl or =
  225.                                         if      over =: mcol
  226.                                                 1 =: mrow
  227.                                                 2swap 2drop 0 0
  228.                                                 2swap
  229.                                                 leave
  230.                                         else    1. d+
  231.                                                 count +
  232.                                         then
  233.                                 loop    2drop
  234.                         then
  235.                 else                    \ search for name in current menu
  236.                         mcol  2* menulist + @         \ addr of menu list
  237.                         2+ 1 swap count 0
  238.                         ?do     dup ucscan bl or menukey bl or =
  239.                                 menukey bl <> and
  240.                                 if      drop =: mrow
  241.                                         13              \ 13 = return
  242.                                         false           \ process command
  243.                                         2swap
  244.                                         leave
  245.                                 else    1. d+           \ bump count
  246.                                         count +         \ step to next item
  247.                                 then
  248.                         loop    2drop
  249.                 then    ;
  250.  
  251. : ?domkey       ( c1 --- c1 | 0 )
  252.                 dup 199 =               \ HOME
  253.                 if      0=
  254.                         mrow 0=                 \ if 0 then
  255.                         if      off> mcol       \ home to left
  256.                         else    off> mrow
  257.                         then                                    then
  258.                 dup 207 =               \ END
  259.                 if      0=
  260.                         mcol  2* menulist + @ 2+ c@ !> mrow     then
  261.                 dup 205 =               \ RIGHT
  262.                 over bl = or
  263.                 if      0=
  264.                         recoverscr
  265.                         mcol menubar c@ 1- =
  266.                         if      0
  267.                         else    mcol   1+ menubar c@ 1- min
  268.                         then    =: mcol
  269.                         mrow 1 min !> mrow                      then
  270.                 dup 203 =               \ LEFT
  271.                 if      0=
  272.                         recoverscr
  273.                         mcol 0=
  274.                         if      menubar c@ 1-
  275.                         else    mcol   1- 0MAX
  276.                         then    =: mcol
  277.                         mrow 1 min !> mrow                      then
  278.                 dup 200 =               \ UP
  279.                 if      0=
  280.                         mrow 1- 0MAX !> mrow
  281.                         begin   1st-rowchar 196 = \ skip over horizontal line
  282.                                 mrow 0> and
  283.                         while   mrow 1- 0MAX !> mrow
  284.                         repeat                                  then
  285.                 dup 208 =               \ DOWN
  286.                 if      0=
  287.                         mrow 1+
  288.                         mcol  2* menulist + @ 2+ c@ dup>r min !> mrow
  289.                         begin   1st-rowchar 196 = \ skip over horizontal line
  290.                                 mrow r@ < and
  291.                         while   mrow 1+ r@ min !> mrow
  292.                         repeat  r> drop
  293.                 then    dup 13 = if 0= then ;
  294.  
  295. headers
  296.  
  297. : menu          ( --- )
  298.                 savecursor              \ save cursor position
  299.                 ['] mbutton save!> dobutton
  300.                 cursor-off
  301.                 nosetcur on
  302.                 off> mrow
  303.                 savescr                 \ Save original screen
  304.                 save> mcol
  305.                 ON>  mcol .menubar      \ display menubar without hilite
  306.                 restore> mcol
  307.                 savescr                 \ save it again
  308.                 begin   showmenus
  309.                         key dup 27 <>           \ while not ESC
  310.                            over 13 <> and       \ and not carraige return
  311.                         ?menukey                \ or menu key
  312.                         if      ?domkey
  313.                         then    ?dup
  314.                 until
  315.                 restscr restscr         \ Recover original screen
  316.                 restore> dobutton
  317.                 restcursor
  318.                 dup     13 =            \ is char a Carraige Return
  319.                 if      drop
  320.                         mcol mrow dofunc  \ then do the function
  321.                 else    dup 27  =
  322.                         if      drop    \ discard if ESC
  323.                         else    doother \ else process the key
  324.                         then
  325.                 then    nosetcur off ;
  326.  
  327. \ WARNING the two words following MUST BE USED together in a single
  328. \ definition. They play with the RETURN stack, and can cause big
  329. \ problems if not balanced.
  330.  
  331. : savemenu      ( --- )         \ save current menu setup
  332.                 2r>
  333.                 save> doother
  334.                 save> menubar
  335.                 save> menulist
  336.                 save> mline
  337.                 save> mcolumn
  338.                 2>r ;
  339.  
  340. : restmenu      ( --- )         \ restore to previous menu setup
  341.                 2r>
  342.                 restore> mcolumn
  343.                 restore> mline
  344.                 restore> menulist
  345.                 restore> menubar
  346.                 restore> doother
  347.                 2>r ;
  348.  
  349. : defmenu       ( --- )
  350.                 defsave =: mcol
  351.                 savemenu
  352.                 default-bar   =: menubar
  353.                 default-list  =: menulist
  354.                 ['] default-mline   is mline
  355.                 ['] default-mcolumn is mcolumn
  356.                 ['] drop            is doother
  357.                 menu
  358.                 restmenu
  359.                 mcol =: defsave ;
  360.  
  361. ' defmenu is esc-in     \ make the menu pop up when user presses ESC.
  362.  
  363. behead
  364.  
  365. only forth also definitions
  366.  
  367.  
  368.