home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / forth / compiler / fpc / source / spread.seq < prev    next >
Text File  |  1989-09-26  |  28KB  |  847 lines
  1. \ SPREAD.SEQ            A Forth Spreadsheet             by Craig A. Lindley
  2.  
  3. comment:
  4.  
  5.   This spreadsheet was published in FORTH Dimensions Volume 7, Number 1
  6. (May/June) and 2 (July/August 1985).  It was written by Craig A. Lindley
  7. of Manitou Springs, Colorado.
  8.  
  9.   Originally written for F83, it runs with minimal modifications for F-PC.
  10. Changes are flaged with "**** change ****"
  11.  
  12.   Typed-in and modified for F-PC by Tom Zimmer. 05/17/89
  13.  
  14.   Most but not all comments from the original listing have been typed into
  15. this listing, so please refer to the original article for further
  16. information.
  17.  
  18. comment;
  19.  
  20.  
  21. anew spreadsheet_program
  22.  
  23.  
  24. \ screen 1      spreadsheet -
  25.  
  26. cr .( Spreadsheet Compiling)
  27.  
  28.  
  29. warning off
  30.  
  31.  
  32. \ screen2       spreadsheet - case statment
  33.  
  34. \ This screen contained a CASE statment, which is already defined in F-PC.
  35.  
  36.  
  37.  
  38. \ screen 3      spreadsheet - constants
  39.  
  40. 26 constant row_max             \ number of spreadsheet rows
  41. 26 constant col_max             \ number of spreadsheet columns
  42. 12 constant col_name_len        \ maximum length of column name
  43. 17 constant row_name_len        \ maximum length of row    name
  44. 21 constant col_org             \ column origin of data on display
  45.  3 constant row_org             \ row    origin of data on display
  46.  6 constant bytes/cell          \ number of bytes per cell
  47.  
  48.  
  49.  
  50.  
  51.  
  52.  
  53.  
  54.  
  55.  
  56. \ screen 4      spreadsheet - variables
  57.  
  58. variable mode_flag              \ auto calculate flag
  59. variable order_flag             \ calculation order flag
  60. variable format_flag            \ numeric output format flag
  61. variable cur_col                \ top left display column number
  62. variable cur_row                \ top left display row    number
  63. variable col_disp               \ column displacement from CUR_COL on display
  64. variable row_disp               \ row    displacement from CUR_ROW on display
  65. variable dict_mark              \ beginning of formula area
  66. variable op_stack 44 allot      \ operator stack for algebraic equation
  67.                                 \ compilation
  68.  
  69.  
  70. \ screen 5      spreadsheet - high level array definitions
  71.  
  72. \ create 2D array depth bytes deep
  73. : array         ( #rows #cols depth -- )        \ compile time
  74.                 ( row# col# -- element_addr )   \ run     time
  75.                 create 2dup swap c, c, * * dup here
  76.                 swap erase allot
  77.                 does> dup c@ 3 roll * 2 roll + over
  78.                         1+ c@ * + 2+ ;
  79.  
  80. \ create 1D string array depth characters deep
  81. : $array        ( #rows depth -- )              \ compile time
  82.                 ( row# -- string_addr )         \ run     time
  83.                 create dup c, * dup here swap blank allot
  84.                 does>  dup c@ rot * + 1+ ;
  85.  
  86.  
  87. \ screen 6      spreadsheet - array definitions
  88.  
  89. \ define a 2D array for spreadsheet data structure
  90. \ each cell contains 6 bytes
  91. \ 2 for formula execution address (if any)
  92. \ 4 for double number value storage
  93.  
  94. row_max col_max bytes/cell array cells
  95.  
  96. \ define a string array for holding the row names
  97. row_max row_name_len $array row_names
  98.  
  99. \ define a string array for holding the column names
  100. col_max col_name_len $array col_names
  101.  
  102.  
  103.  
  104.  
  105.  
  106.  
  107.  
  108.  
  109.  
  110.  
  111. \ screen 7      spreadsheet - misc word definitions
  112.  
  113. \ "IBM_key" was defined here but is not needed.
  114.  
  115. : d#in          ( -- d1 )               \ input double number from keyboard
  116.                 pad 1+ 20 2dup blank expect
  117.                 span @ pad c! pad number ;
  118.  
  119. : #in           ( -- n1 )               \ input single number from keyboard
  120.                 d#in drop ;
  121.  
  122.  
  123. \ screen 8      spreadsheet - misc word definitions
  124.  
  125. : pos1          ( -- )                  \ position cursor on command line one
  126.                 0 21 2dup at eeol at ;  \ and erase line
  127.  
  128. : pos2          ( -- )                  \ position cursor on command line two
  129.                 0 22 2dup at eeol at ;  \ and erase line
  130.  
  131. : y/n           ( -- bool )             \ bool = TRUE if yes, FALSE if no
  132.                 pos1 ." Are You Sure ?: "       \ display message
  133.                 key upc ascii Y = ;             \ return flag
  134.  
  135. : mark_cell     ( row# col# -- )        \ make a cell on the display
  136.                 2dup at ascii < emit swap 11 + swap at ascii > emit ;
  137.  
  138. : unmark_cell   ( row# col# -- )        \ unmark a cell on the display
  139.                 2dup at space swap 11 + swap at space ;
  140.  
  141.  
  142. \ screen 9      spreadsheet - misc word definitions
  143.  
  144. : cell_ptr      ( -- cell_addr )        \ return the address of the cell
  145.                 cur_row @ row_disp @ +  \ pointed at by <   > display marker
  146.                 cur_col @ col_disp @ +
  147.                 cells ;
  148.  
  149. : cal_cell_disp_loc     ( -- col row )  \ calculate location on display of
  150.                 col_disp @ 13 * col_org +       \ cell display markers
  151.                 row_disp @      row_org + ;
  152.  
  153. : place_cell_marker     ( -- )          \ place cell markers around cell
  154.                 cal_cell_disp_loc mark_cell ;
  155.  
  156. : erase_cell_marker     ( -- )          \ erase cell markers from around cell
  157.                 cal_cell_disp_loc unmark_cell ;
  158.  
  159.  
  160.  
  161.  
  162.  
  163.  
  164.  
  165.  
  166. \ screen 10     spreadsheet - misc word definitions
  167.  
  168. : (fd.)         ( d1 -- a1 n1 )         \ dollar/cents formating word,
  169.                 tuck dabs               \ formats d1 and includes leading "$"
  170.                 <# # # ascii . hold #s rot
  171.                 sign ascii $ hold #> ;
  172.  
  173. : fd.r          ( d1 width -- )         \ format d1 in dollars/cents in a
  174.                                         \ right justified field of width
  175.                 >r (fd.) r> over - spaces type ;
  176.  
  177. : format#       ( d1 -- )               \ format d1 in one of two formats
  178.                 format_flag @           \ as dollars/cents or a normal number
  179.                 if      10 fd.r
  180.                 else    10  d.r
  181.                 then    ;
  182.  
  183.  
  184. \ screen 11     spreadsheet - display word definitions
  185.  
  186. : dis_data      ( -- )                  \ display all cell data for 4 columns
  187.                 cur_col @ dup 4 + swap
  188.                 do      i col_max = ?leave
  189.                         cur_row @ dup 15 + swap              \ and 15 rows
  190.                         do      i row_max = ?leave
  191.                                 j cur_col @ - 13 * 22 +
  192.                                 i cur_row @ -       3 + at
  193.                                 i j cells 2+ 2@ format#
  194.                         loop
  195.                 loop    ;
  196.  
  197. \ screen 12     spreadsheet - display word definitions
  198.  
  199. \ display the spreadsheet border on the screen
  200.  
  201. : dis_border    ( -- )                  \ display spreadsheet border
  202.                 18 3
  203.                 do      20 i at 4 0
  204.                         do      ." │" 12 spaces
  205.                         loop    ." │"
  206.                 loop
  207.                 80 0
  208.                 do      i 2 at ascii - emit loop
  209.                 80 0
  210.                 do      i 18 at ascii - emit loop ;
  211.  
  212.  
  213.  
  214.  
  215.  
  216.  
  217.  
  218.  
  219.  
  220.  
  221. \ screen 13     spreadsheet - display word definitions
  222.  
  223. \ display the spreadsheet menu of options on the right side of display
  224.  
  225. : dis_menu      ( -- )                  \ display menu
  226.                 74  3 at ." Menu:"
  227.                 74  4 at ." C)ol"       74  5 at ." A)gain"
  228.                 74  6 at ." D)ata"      74  7 at ." E)qu."
  229.                 74  8 at ." F)orm"      74  9 at ." G)oto"
  230.                 74 10 at ." M)ode"      74 11 at ." N)ew"
  231.                 74 12 at ." O)rder"     74 13 at ." P)ref"
  232.                 74 14 at ." Q)uit"      74 15 at ." R)ow" ;
  233.  
  234.  
  235. \ screen 14     spreadsheet - display word definitions
  236.  
  237. : dis_row_labels        ( -- )          \ label the rows on display
  238.                 cur_row @ dup 15 + swap
  239.                 do      i row_max = ?leave
  240.                         18 i cur_row @ - 3 + at
  241.                         i 2 .r
  242.                 loop    ;
  243.  
  244. : dis_row_names         ( -- )          \ display row names from array
  245.                 cur_row @ dup 15 + swap
  246.                 do      i row_max = ?leave
  247.                         0 i cur_row @ - 3 + at
  248.                         i row_names row_name_len type
  249.                 loop    ;
  250.  
  251. \ screen 15     spreadsheet - display word definitions
  252.  
  253. : dis_col_labels        ( -- )          \ label the columns on display
  254.                         cur_col @ dup 4 + swap
  255.                         do      i col_max = ?leave
  256.                                 i cur_col @ - 13 * 27 + 2 at
  257.                                 i ascii A + emit
  258.                         loop    ;
  259.  
  260. : dis_col_names         ( -- )          \ display column names
  261.                         7 1 at ." Title"
  262.                         cur_col @ dup 4 + swap
  263.                         do      i col_max = ?leave
  264.                                 i cur_col @ - 13 * 21 + 1 at
  265.                                 i col_names col_name_len type
  266.                         loop    ;
  267.  
  268.  
  269.  
  270.  
  271.  
  272.  
  273.  
  274.  
  275.  
  276. \ screen 16     spreadsheet - display word definitions
  277.  
  278. : dis_status    ( -- )                  \ display spreadsheet status
  279.                 48 19 at ." Row: "
  280.                 cur_row @ row_disp @ + .
  281.                 60 19 at ." Column: "
  282.                 cur_col @ col_disp @ + ascii A + emit
  283.                 47 20 at ." Mode: " mode_flag @
  284.                 if      ." Auto  " else ." Normal" then
  285.                 61 20 at ." Order: " order_flag @
  286.                 if      ." C/R" else ." R/C" then
  287.                 pos2
  288.                 pos1 ." Command: "
  289.                 place_cell_marker ;
  290.  
  291.  
  292. \ screen 17     spreadsheet - display word definitions
  293.  
  294. : dis_row_change        ( -- )          \ display info that changes with
  295.                 dis_row_names           \ a row change
  296.                 dis_row_labels          \ col names, labels and data
  297.                 dis_data ;
  298.  
  299. : dis_col_change        ( -- )          \ display info chat changes with
  300.                 dis_col_names           \ a col change
  301.                 dis_col_labels          \ col names, labels and data
  302.                 dis_data ;
  303.  
  304. \ screen 18     spreadsheet - display word definitions
  305.  
  306. : dis_screen    ( -- )                  \ display entire spreadsheet screen
  307.                 dark 31 0 at
  308.                 ." Forth Spreadsheet"   \ display title
  309.                 dis_border              \ draw borders
  310.                 dis_menu                \ display operation menu
  311.                 dis_col_labels          \ label columns (A-Z)
  312.                 dis_col_names           \ display column names
  313.                 dis_row_labels          \ label rows    (0-25)
  314.                 dis_row_names           \ display row    names
  315.                 dis_data                \ display appropriate data
  316.                                         \ for data window being displayed
  317.                 0 row_disp !            \ set mark to origin
  318.                 0 col_disp !
  319.                 dis_status ;            \ display status
  320.  
  321.  
  322.  
  323.  
  324.  
  325.  
  326.  
  327.  
  328.  
  329.  
  330.  
  331. \ screen 19     spreadsheet - cell calculation words
  332.  
  333. : calculate     ( cell_addr -- )        \ calc formula of cell if it has one
  334.                 @ ?dup if execute then ;
  335.  
  336. : calc_c/r      ( -- )                  \ calculate columns then rows
  337.                 row_max 0
  338.                 do      col_max 0
  339.                         do      j i cells calculate
  340.                         loop
  341.                 loop    ;
  342.  
  343. : calc_r/c      ( -- )                  \ calculate rows then columns
  344.                 col_max 0
  345.                 do      row_max 0
  346.                         do      i j cells calculate
  347.                         loop
  348.                 loop    ;
  349.  
  350.  
  351. \ screen 20     spreadsheet - cell calculation words
  352.  
  353. : calc_cells    ( -- )                  \ calculate according to previously
  354.                 order_flag @            \ specified order
  355.                 if      calc_c/r
  356.                 else    calc_r/c
  357.                 then    ;
  358.  
  359. : order         ( -- )                  \ prompt user for calculation order
  360.                 pos1 ." Specify calculation order"
  361.                 pos2 ." Row/Col(0) or Col/Row(1): "
  362.                 key ascii 1 =
  363.                 if      true
  364.                 else    false
  365.                 then    order_flag ! ;
  366.  
  367. \ screen 21     spreadsheet - cell marker positioning words
  368.  
  369. : left_arrow    ( -- )                  \ move cell marker left one cell
  370.                 col_disp @ 0=
  371.                 if      cur_col @ 0<>
  372.                         if      -1 cur_col +!
  373.                                 dis_col_change
  374.                         then
  375.                 else    erase_cell_marker
  376.                         -1 col_disp +!
  377.                 then    place_cell_marker ;
  378.  
  379.  
  380.  
  381.  
  382.  
  383.  
  384.  
  385.  
  386. \ screen 22     spreadsheet - cellmarker positioning words
  387.  
  388. : right_arrow   ( -- )                  \ move cell marker right one cell
  389.                 col_disp @ 3 =
  390.                 if      cur_col @ 4 + col_max <>
  391.                         if      1 cur_col +!
  392.                                 dis_col_change
  393.                         then
  394.                 else    erase_cell_marker
  395.                         1 col_disp +!
  396.                 then    place_cell_marker ;
  397.  
  398. \ screen 23     spreadsheet - cell marker positioning words
  399.  
  400. : up_arrow      ( -- )                  \ move cell marker up one cell
  401.                 row_disp @ 0=
  402.                 if      cur_row @ 0<>
  403.                         if      -1 cur_row +!
  404.                                 dis_row_change
  405.                         then
  406.                 else    erase_cell_marker
  407.                         -1 row_disp +!
  408.                 then    place_cell_marker ;
  409.  
  410.  
  411. \ screen 24     spreadsheet - cell marker positioning words
  412.  
  413. : down_arrow    ( -- )                  \ move cell marker down one cell
  414.                 row_disp @ 14 =
  415.                 if      cur_row @ 15 + row_max <>
  416.                         if      1 cur_row +!
  417.                                 dis_row_change
  418.                         then
  419.                 else    erase_cell_marker
  420.                         1 row_disp +!
  421.                 then    place_cell_marker ;
  422.  
  423.  
  424.  
  425.  
  426.  
  427.  
  428.  
  429.  
  430.  
  431.  
  432.  
  433.  
  434.  
  435.  
  436.  
  437.  
  438.  
  439.  
  440.  
  441. \ screen 25     spreadsheet - cell marker positioning words
  442.  
  443. : first_col     ( -- )                  \ go to column A immediately
  444.                 0 cur_col !
  445.                 dis_col_change ;
  446.  
  447. : last_col      ( -- )                  \ go to column W immediately
  448.                 col_max 4 - cur_col !
  449.                 dis_col_change ;
  450.  
  451. : top_row       ( -- )                  \ go to row 0 immediately
  452.                 0 cur_row !
  453.                 dis_row_change ;
  454.  
  455. : bottom_row    ( -- )                  \ go to row 11 immediately
  456.                 row_max 15 - cur_row !
  457.                 dis_row_change ;
  458.  
  459. \ screen 26     spreadsheet - cell marker positioning words
  460.  
  461. : left_4_cols   ( -- )                  \ move marker left four columns
  462.                 4 0 do left_arrow loop ;
  463.  
  464. : right_4_cols  ( -- )                  \ move marker right four columns
  465.                 4 0 do right_arrow loop ;
  466.  
  467.  
  468. \ screen 27     spreadsheet - algebraic functions
  469.  
  470. vocabulary algebra
  471.  
  472. algebra also definitions
  473.  
  474. \ The COL_ID function assigns n1 to <name> at compile time.
  475. \ It expects row number as n1 at run time.
  476. \ Subsequent usage of <name> fetches the double value of the cell
  477. \ to the stack.
  478.  
  479. : col_id                                \ column_id high level defining word
  480.                 ( n1 | <name> -- )      \ compile time
  481.                 ( n1 --- cell_value )   \ run     time
  482.                 create ,
  483.                 does> @ cells 2+ 2@ ;
  484.  
  485.  
  486.  
  487.  
  488.  
  489.  
  490.  
  491.  
  492.  
  493.  
  494.  
  495.  
  496. \ screen 28     spreadsheet - algebraic functions
  497.  
  498. : assign_id     ( | <many_names> -- )   \ loop used to assign value to
  499.                 col_max 0               \ the alphabetic columns
  500.                 do      i col_id
  501.                 loop    ;
  502.  
  503. assign_id  A B C D E F G H I J K L M N O P Q R S T U V W X Y Z
  504.  
  505. \ for example 1 A returns teh couble int value of cell 1 A.
  506. \ Column ids A-Z return values of 0-25 respectively
  507.  
  508.  
  509. \ screen 29     spreadsheet - algebraic functions
  510.  
  511. : opp@          ( -- addr )             \ return operand stack position
  512.                 op_stack dup @ + ;      \ first location is stack pointer
  513.  
  514. : >op           ( cfa prec -- )         \ store CFA and precedence to
  515.                 4 op_stack +! opp@ 2! ; \ top of operand stack
  516.  
  517. : op>           ( -- )                  \ pop CFA and precedence off operand
  518.                 opp@ 2@                 \ stack and compile into dictionary
  519.                 -4 op_stack +!
  520.                 drop x, ;               \ *** changed *** "," to "x,"
  521.  
  522. : prec?         ( -- prec )             \ return precedence from top
  523.                 opp@ @ ;                \ of operand stack
  524.  
  525. : ]a            ( -- )                  \ end algebraic compilation
  526.                 begin   prec?           \ pop remaining operands off stack
  527.                 while   op>             \ and compile then select FORTH voc.
  528.                 repeat  forth ; immediate
  529.  
  530.  
  531. \ screen 30     spreadsheet - algebraic functions
  532.  
  533. \ create a high level definition that performs algebraic compilation.
  534. \ See article for details of operation.
  535.  
  536. : infix         ( n1 | <name> <name2> -- )      \ create a new algebraic
  537.                 ' create swap , , immediate     \ operator
  538.                 does> 2@
  539.                 begin   dup prec? > not
  540.                 while   >r >r op> r> r>
  541.                 repeat  >op ;
  542.  
  543. : d*            ( d1 d2 -- d3 )         \ double multiplication
  544.                 dup rot * rot rot um* rot + ;
  545.  
  546. : d/            ( d1 d2 -- d3 )         \ double division
  547.                 swap over /mod >r swap um/mod swap drop r> ;
  548.  
  549. : dmod          ( d1 d2 -- d3 )         \ double modulus
  550.                 d/ drop 0 ;
  551.  
  552. \ screen 31     spreadsheet - algebraic functions
  553.  
  554. \ create the new algebraic operators with assigned precedence
  555.  
  556. 7 infix d* *
  557. 7 infix d/ /
  558. 6 infix d+ +
  559. 6 infix d- -
  560. 5 infix dmod mod
  561.  
  562. : )missing      ( -- )                  \ missing ")" error handler
  563.                 true abort" Missing )" ;
  564.  
  565. : (             ( -- )                  \ prec = 1 cfa=)missing message
  566.                                         \ lowest precedence, push on
  567.                                         \ operand stack.
  568.                 ['] )missing 1 >op ; immediate
  569.  
  570.  
  571. \ screen 32     spreadsheet - algebraic functions
  572.  
  573. : )             \ ( -- )                \ right paren causes all items on
  574.                 [ forth ]               \ operand stack to be compiled
  575.                 begin   1 prec? <       \ until a left paren is found
  576.                 while   op>
  577.                 repeat                  \ left paren should have a precedence
  578.                 1 prec? =               \ of one or error message results
  579.                 if      -4 op_stack +!
  580.                 else    true abort" Missing ("
  581.                 then    ; immediate
  582.  
  583. forth definitions
  584.  
  585. : a[            ( -- )                  \ start algebraic compilation
  586.                 0 op_stack ! algebra ;  \ reset operand stack and select
  587.                 immediate               \ algebra vocabulary
  588.  
  589. \ screen 33     spreadsheet - input words
  590.  
  591. : input_row_names       ( -- )          \ input row names
  592.                 pos1 ." Input Row Names"
  593.                 pos2 ." Starting with Row: "
  594.                 #in cur_row !
  595.                 row_max cur_row @
  596.                 do      pos2 ." Row " i 2 .r ." : "
  597.                         i row_names row_name_len
  598.                         2dup blank expect
  599.                         span @ 0= ?leave
  600.                         i 5 mod 0=
  601.                         if      i cur_row !
  602.                                 dis_row_change
  603.                         else    dis_row_names
  604.                         then
  605.                 loop ;
  606.  
  607.  
  608. \ screen 34     spreadsheet - input words
  609.  
  610. : input_col_names       ( -- )          \ input column names
  611.                 pos1 ." Input Col Names"
  612.                 pos2 ." Starting with Col: "
  613.                 key upc ascii A - cur_col !
  614.                 col_max cur_col @
  615.                 do      pos2 ." Col " i ascii A + emit ." : "
  616.                         i col_names col_name_len
  617.                         2dup blank expect
  618.                         span @ 0= ?leave
  619.                         i 4 mod 0=
  620.                         if      i cur_col !
  621.                                 dis_col_change
  622.                         else    dis_col_names
  623.                         then
  624.                 loop ;
  625.  
  626.  
  627. \ screen 35     spreadsheet - input words
  628.  
  629. : get#          ( -- n1 )               \ get a number, scale if needed
  630.                 d#in
  631.                 format_flag @
  632.                 if      dpl @ 3 min
  633.                         case
  634.                                 -1 of 100 d*    endof
  635.                                  0 of 100 d*    endof
  636.                                  1 of  10 d*    endof
  637.                                  2 of noop      endof
  638.                                  3 of 10 d/     endof
  639.                                 drop
  640.                         endcase
  641.                 then    ;
  642.  
  643. \ screen 36     spreadsheet - input words
  644.  
  645. : input_cell_data       ( -- )          \ input data to cells
  646.                 pos1 ." Input Cell Data"
  647.                 pos2 ." Data: " get#
  648.                 cell_ptr 2+ 2!
  649.                 mode_flag @
  650.                 if      pos2 ." Calculating"
  651.                         calc_cells
  652.                 then    dis_data ;
  653.  
  654.  
  655.  
  656.  
  657.  
  658.  
  659.  
  660.  
  661.  
  662. \ screen 37     spreadsheet - input words
  663.  
  664. : input_equ     ( -- )                  \ input equations into dictionary
  665.                 pos1 ." Input Cell Equation"
  666.                 pos2 ." Eqquation: "
  667.                 tib 127 blank
  668.                 " : formula a[ " tib swap cmove
  669.                 tib 13 + dup 127 expect
  670.                 span @ +
  671.                 "  ]a [ cell_ptr 2+ ] literal 2! ; last @ name> cell_ptr !"
  672.                 -rot swap rot cmove
  673.                 span @ 70 + #tib !
  674.                 >in off
  675.                 algebra
  676.                 interpret
  677.                 forth ;
  678.  
  679.  
  680. \ screen 38     spreadsheet - high level commands
  681.  
  682. : quit_calc     ( -- )                  \ exit spreadsheet
  683.                 y/n abort" BYE" ;
  684.  
  685. : new           ( -- )                  \ clear existing spreadsheet
  686.                 y/n
  687.                 if      0 0 cells
  688.                         row_max col_max bytes/cell * * erase
  689.                         0 row_names row_max row_name_len * erase
  690.                         0 col_names col_max col_name_len * erase
  691.                         dict_mark perform
  692.                         0 row_disp !
  693.                         0 col_disp !
  694.                         dis_screen
  695.                 then    ;
  696.  
  697.  
  698. \ screen 39     spreadsheet - high level commands
  699.  
  700. : mode          ( -- )                  \ set the auto calculation mode
  701.                 pos1 ." Set auto calculation mode"
  702.                 pos2 ." Normal=0 or Auto=1: "
  703.                 key ascii 1 =
  704.                 if      true
  705.                 else    false
  706.                 then    mode_flag ! ;
  707.  
  708. : perform_calc  ( -- )                  \ force a re-calculation of
  709.                 calc_cells              \ entire spreadsheet
  710.                 dis_data ;
  711.  
  712.  
  713.  
  714.  
  715.  
  716.  
  717. \ screen 40     spreadsheet - high level commands
  718.  
  719. : format        ( -- )                  \ select the number display format
  720.                 pos1 ." Select input number format"
  721.                 pos2 ." Normal=0 or Dollars/Cents=1: "
  722.                 key ascii 1 =
  723.                 if      true
  724.                 else    false
  725.                 then    format_flag !
  726.                 dis_data ;
  727.  
  728.  
  729. \ screen 41     spreadsheet - high level commands
  730.  
  731. : again_repl    ( -- )                  \ replicate column data
  732.                 cell_ptr 2+ 2@
  733.                 pos1 ." Column replicate cell data"
  734.                 pos2 ." Number of columns: "
  735.                 #in ?dup
  736.                 if      0
  737.                         do      right_arrow
  738.                                 2dup cell_ptr 2+ 2!
  739.                         loop
  740.                         2drop
  741.                         dis_data
  742.                 then    ;
  743.  
  744.  
  745. \ screen 42     spreadsheet - high levle commands
  746.  
  747. : go_to         ( -- )                  \ goto a specified row/col
  748.                 pos1 ." Row(0-25): "
  749.                 #in dup 0 row_max within
  750.                 if      cur_row !
  751.                         pos2 ." Column(A-W): "
  752.                         key upc ascii A - dup
  753.                         0 col_max 3 - within
  754.                         if      cur_col !
  755.                                 0 col_disp !
  756.                                 0 row_disp !
  757.                                 dis_screen
  758.                         else    drop
  759.                         then
  760.                 else    drop
  761.                 then    ;
  762.  
  763.  
  764.  
  765.  
  766.  
  767.  
  768.  
  769.  
  770.  
  771.  
  772. \ screen 43     spreadsheet - operator input processing
  773.  
  774. : command_in    ( c1 -- )               \ do a user command
  775.                 upc             \ *** changed ***
  776.                                 \ UPC moved here from screen 45
  777.                                 \ for compatibility with F-PC
  778.                 case
  779.                         ascii A of again_repl           endof
  780.                         ascii C of input_col_names      endof
  781.                         ascii D of input_cell_data      endof
  782.                         ascii E of input_equ            endof
  783.                         ascii F of format               endof
  784.                         ascii G of go_to                endof
  785.                         ascii M of mode                 endof
  786.                         ascii N of new                  endof
  787.                         ascii O of order                endof
  788.                         ascii P of perform_calc         endof
  789.                         ascii Q of quit_calc            endof
  790.                         ascii R of input_row_names      endof
  791.                                    drop beep
  792.                 endcase ;
  793.  
  794.  
  795. \ screen 44     spreadsheet - operator input processing
  796.  
  797. : control_in    ( c1 -- )               \ do a user movement command
  798.                 case
  799.                         199 ( Home )    of top_row          endof
  800.                         200 ( Up )      of up_arrow         endof
  801.                         201 ( PgUp )    of left_4_cols      endof
  802.                         203 ( Left )    of left_arrow       endof
  803.                         205 ( Right )   of right_arrow      endof
  804.                         207 ( End )     of bottom_row       endof
  805.                         208 ( Down )    of down_arrow       endof
  806.                         209 ( PgDn )    of right_4_cols     endof
  807.                         243 ( ^Left )   of first_col        endof
  808.                         244 ( ^Right )  of last_col         endof
  809.                             ( any other )  drop beep
  810.                 endcase ;
  811.  
  812.  
  813.  
  814.  
  815.  
  816.  
  817.  
  818.  
  819.  
  820.  
  821.  
  822.  
  823.  
  824.  
  825.  
  826. \ screen 45     spreadsheet - main program
  827.  
  828. : spreadsheet   ( -- )                  \ main program word
  829.                 dis_screen
  830.                 begin   key             \ *** changed ***
  831.                                         \ switched to F-PC's key, moved UPC
  832.                                         \ to screen 43
  833.                         dup 198 >
  834.                         if      control_in
  835.                         else    command_in
  836.                         then
  837.                         dis_status
  838.                 again   ;
  839.  
  840. mark no_formulas                        \ dict_mark has CFA of word to
  841. ' no_formulas dict_mark !               \ delete formulas
  842.  
  843. warning on                              \ turn warning messages back on
  844.  
  845. cr .( Spreadsheet Compile complete. )
  846.  
  847.