\ Mini Spreadsheet
\ in Gforth 0.6.2 (console mode)
\ Contributed by Chess Player , expandafter at yahoo.com
\ from Andreas' practical language comparison: Test case: Mini
\ Spreadsheet using Forth.
\ from http://wiki.forthfreak.net/index.cgi?MiniSpreadsheet
\ small improvements by Anton Ertl:
\ - used Gforth's key names instead of magic constants
\ - used FORM to get screen size instead of magic constants
\ - eliminated QUIT
\ If you're not using a DOS-box under Windows, your arrow keys may
\ yield different numbers and you'll need to change the constants.
\ * Run by typing main.
\ * If you accidentally quit without saving your work, type
\ mainloop to get back to your sheet.
\ * Labels: begin with "'".
\ * Formulas:
\ o begin with "=";
\ o a3:b12 sums a range;
\ o all operators have equal precedence, so to figure area
\ of circle with radius of 5, use 3.14*(5^2).
\ * Commands:
\ ESC q Quit
\ ESC s Save
\ ESC l Load
\ ESC c Recalculate
\ ESC p Set decimal places
\ ; Copy a cell
\ , Paste and move right
\ / Paste and move down
decimal \ Initialize constants.
80 constant winwd 25 constant winht winht 2 - constant visrows
11 constant slotwd winwd 2 - slotwd / 1+ constant viscols
31 constant strsize 99 constant maxrow 25 constant maxcol
maxcol viscols - 2 + constant maxcorner_x
maxrow winht - 3 + constant maxcorner_y
\ Arrow keys.
30824 30848 30872 30896 constant down constant up constant right constant left
30992 constant pagedown 30968 constant pageup 27 constant esc
2 value decimalplaces 2variable currentpos
0 value corner_x 0 value corner_y \ The cell shown in upper, left corner.
maxrow 1+ maxcol 1+ * dup create farrayadr floats allot
create sarrayadr strsize 1+ * allot create copied 256 allot
create mypad 256 allot
2variable from
: farray ( x y -- address) maxcol 1+ * + floats farrayadr + ;
: sarray ( x y -- address) maxcol 1+ * + strsize 1+ * sarrayadr + ;
: cfind ( c cadr n -- n) { c adr n } -1
adr n bounds ?do i c@ c = if drop i adr - leave then loop ;
: tidy ( n1 n2 -- larger+1 smaller) 2dup max 1+ -rot min ;
: letter? ( c--flag) toupper 'A 'Z 1+ within ;
: digit? ( c--flag) '0 '9 1+ within ;
: outside? ( x y -- flag) 0 maxrow 1+ within 0= swap 0 maxcol 1+ within
0= or ;
: bottom 0 winht 1- 2dup at-xy winwd 1- spaces at-xy ;
: error bottom type ." Press a key:" ekey drop ;
: sumrange ( x y x y -- F:sum) rot tidy { a b } tidy { c d }
0.0e a b do c d do i j farray f@ f+ loop loop ;
: ref? ( cadr n -- cadr n flag) over c@ letter? ;
\ Convert slot reference (e.g., "j35") to x,y.
: ref ( cadr n -- x y) 'A 10 { adr n offset mul } n 2 < throw
adr n bounds ?do i c@ toupper offset - '0 to offset loop
n 2 - 0 ?do swap mul * + mul 10 * to mul loop
2dup outside? if s" Out-of-bounds reference." error 1 throw then ;
: doref ( cadr n -- F:f) -1 { adr n p }
': adr n cfind to p ( Range?)
p -1 > if adr p ref adr p + 1+ n p - 1- ref? 0= throw ref sumrange
else adr n ref farray f@ then ;
: ops s" */+-^()" ;
create optable ' f* , ' f/ , ' f+ , ' f- , ' f** ,
: opfind ( c -- n) ops cfind ;
: op? ( c -- c flag) dup opfind -1 > ;
create opstack 256 cells allot opstack cell - value sp
: push sp cell+ to sp sp ! ;
: copy sp @ ; : pop copy sp cell - to sp ;
0 push
: run ( c --) fdepth 2 < throw opfind cells optable + @ execute ;
: doop { op } op '( = if op push exit then
begin copy dup '( <> and while pop run repeat
op ') = if pop drop else op push then ;
: doval ( op adr -- ) 0 { op adr len } here adr - to len
len if adr len ref? if doref else >float 0= throw then
len negate allot then op doop ;
: infix ( cadr n -- F:f) here { mark }
bounds ?do i c@ op?
( ) over s" +-" cfind 0< here mark - or and ( For unary +-.)
if mark doval else dup BL = if drop else c, then then
loop 0 mark doval pop drop
\ Error if operator left on opstack.
copy if begin pop drop copy 0= until 1 throw then ;
defer afunc
: doarray ( xt --) is afunc
maxrow 1+ 0 do maxcol 1+ 0 do i j afunc loop loop ;
: fa! ( F:f x y --) farray fdup f! ;
: fillfarray ( f --) ['] fa! doarray fdrop ;
: sa! ( cadr n x y --) sarray place ;
: emptyslot ( x y --) sarray 0 swap ! ;
: emptysarray ['] emptyslot doarray ;
: .empty slotwd 1- 0 ?do ." ." loop ;
: pos@ currentpos 2@ ;
: pos! currentpos 2! ;
: >indices ( col row -- i j) 1- corner_y + swap 1- corner_x + swap ;
: ind@ pos@ >indices ;
: .val ( f --) slotwd 1- decimalplaces 2 f.rdp ;
: head ( col --) ?dup if corner_x + 64 + slotwd 2/ else 32 1 then spaces emit ;
: at-slot ( col row --) swap 1- slotwd * 2 + 0 max swap at-xy ;
: disp ( x y --) { x y } space x y sarray count ?dup
if over c@ [char] ' = \ Label.
if pad slotwd blank 1 /string pad swap move pad slotwd 1- type
else 2drop x y farray f@ .val then
else drop .empty then ;
: (show_slot) { col row } col row >indices col if ( Print cell value.) disp
else ( Print row number.) 2 .r drop then ;
: show_slot ( col row --) 2dup at-slot ?dup if (show_slot) else head then ;
: showrow ( row --) 0 over at-xy viscols 0 do i over show_slot loop drop ;
: at-current pos@ at-slot ;
: show winht 1- 0 do i showrow loop at-current ;
: bounded ( n dn minimum ceiling offset maxoffset -- n offset)
{ n dn minimum ceiling offset maxoffset }
n dn + minimum ceiling within
if n dn + offset else n offset dn + 0 max maxoffset min then ;
: move_rel ( dx dy --) \ Move to another cell.
pos@ { dx dy x y } corner_x corner_y \ Save current view on stack.
x dx 1 viscols corner_x maxcorner_x bounded to corner_x
y dy 1 winht 1- corner_y maxcorner_y bounded to corner_y
pos! corner_x corner_y d<> if ( View has shifted.) show then
at-current ;
: set-dec-places ( -- ) bottom ." Decimal places? " pad 1 accept pad swap
-trailing dup
if 0. 2swap >number nip
if s" Bad integer." error 2drop else d>s to decimalplaces then
else 2drop then ;
: calcstr ( cadr n -- F:f) 0 { adr n ch } n
if adr c@ to ch
[char] ' ch = if 0.0e exit then
'= ch = if adr n 1 /string infix exit then
adr n >float 0= throw
else 0.0e then ;
: calcslot ( x y --) 2dup sarray count calcstr farray f! ;
: edit ( c--) bottom ind@ 2dup sarray { x y sadr } x 65 + emit y 1 .r ." >"
?dup if 1 sadr c! sadr 1+ c! ( 1 char. has been typed.) then
sadr count strsize swap edit-line sadr c! x y ['] calcslot catch if 2drop
s" Bad cell (use = for formulas, ' for labels)." error 0 recurse
then pos@ show_slot ;
: calc ( col row --) 2dup sarray count calcstr farray f! ;
: calc_all bottom ." Calculating..." ['] calc doarray
show bottom ." ...calculated." ;
: update-current ind@ calcslot at-current pos@ show_slot ;
: tocorner 1 1 pos! at-current ;
: page_ { p1 sign p2 } pos@ drop dup p1 pos! 0 visrows sign * move_rel
p2 pos! ;
: page_down visrows 1 1 page_ ; : page_up 1 -1 visrows page_ ;
: 2>str ( n1 n2--cadr u) s>d <# #s bl hold 2drop s>d #s #> ;
0 value handle
: wr ( cadr n--) handle write-line throw ;
: wr-slot { x y } x y sarray count ?dup if x y 2>str wr wr else drop then ;
: wr-array ['] wr-slot doarray ;
: getfname ( --cadr n) bottom type pad 64 accept pad swap ;
: open ( cadr n mode--ior) open-file ?dup if nip s" Cannot open file." error
else to handle 0 then ;
: close ( --ior) handle close-file
if s" Error while closing file." error then ;
: save s" Save to file: " getfname w/o open if exit then ['] wr-array catch
if s" Error while writing to file." error then close ;
: fload 1 { x } s" Load file: " getfname r/o open if exit then
begin pad 80 handle read-line ( n flag ior)
if drop 0 s" Error while reading file." error then
while pad swap -trailing x 1 and if evaluate else 2swap sa! then x 1+ to x
repeat drop close calc_all ;
variable ,,held 2variable form-offset
: ,, ( c --) dup \ As characters are tacked on, look for slot reference.
,,held @
if digit?
if 1 ,,held +!
else pad 1+ ,,held @ ref ( x y)
form-offset 2@ d+ 2dup outside?
if 2drop s" Adjusted reference would be out of bounds." error 1 throw
then swap 'a + c, s>d <# #s #>
begin dup while over c@ c, 1 /string repeat 2drop ,,held off
then
else letter? if 1 ,,held ! then
then ,,held @ ?dup if pad + c! else ?dup if c, then then ;
\ Adjust slot-references when pasting so that they have the same relation
\ to the current slot that they did to the source slot.
: fix-formula ( cadr n -- cadr n) here { mark } ,,held off
ind@ from 2@ d- form-offset 2!
bounds do i c@ ,, loop 0 ,,
mark here mark - mypad place mark here - allot mypad count ;
: copy-slot ind@ 2dup from 2! sarray count copied place bottom ." Copied." ;
: paste copied count
['] fix-formula catch if 2drop copied count then
ind@ sarray place update-current ;
: mainloop 0 256 0 { x m mess } 0 copied ! tocorner show
begin ekey ( Get key.) 65535 and x or 0 to mess
case
esc of m to x endof
'q m or of page quit endof
's m or of 0 to x save endof
'l m or of 0 to x fload endof
'c m or of 0 to x calc_all 1 to mess endof
'p m or of 0 to x set-dec-places endof
13 of 0 edit 0 1 move_rel endof
left of -1 0 move_rel endof
right of 1 0 move_rel endof
up of 0 -1 move_rel endof
down of 0 1 move_rel endof
pagedown of page_down endof
pageup of page_up endof
'; of copy-slot 1 to mess endof
', of paste 1 0 move_rel endof
'/ of paste 0 1 move_rel endof
dup 33 128 within if dup edit 0 1 move_rel then
endcase mess 0= if bottom ind@ sarray count type then at-current
again ;
: main page 0.0e fillfarray emptysarray 0 to corner_x 0 to corner_y
mainloop ;