Commits

Anonymous committed f6dcf2e

Nbody in Forth with slightly different approach

Comments (0)

Files changed (2)

+requires fpmath
+
+pi pi f* 4e f* fconstant solarmass
+365.24e fconstant #days
+5 constant nb
+
+: f?  f@ f. ;
+
+\ We need the reversed loop because of the reversed order of the numbers to be stored
+: coord:  create here 1- here nb 1- floats + do I f! 1 floats negate +loop  nb floats allot 
+          does> swap floats + ;
+: .coord:  ( xt -- )  create , does> @ nb 0 do I over execute f? loop drop ; 
+
+0e	4.84143144246472090e+00		8.34336671824457987e+00		1.28943695621391310e+01		1.53796971148509165e+01 	coord: x  ' x .coord: .x
+0e	-1.16032004402742839e+00	4.12479856412430479e+00 	-1.51111514016986312e+01	-2.59193146099879641e+01 	coord: y  ' y .coord: .y
+0e	-1.03622044471123109e-01	-4.03523417114321381e-01	-2.23307578892655734e-01	1.79258772950371181e-01		coord: z  ' z .coord: .z
+
+0e 1.66007664274403694e-03 #days f*
+-2.76742510726862411e-03 #days f*
+2.96460137564761618e-03 #days f*
+2.68067772490389322e-03 #days f*
+coord: vx
+' vx .coord: .vx
+
+0e
+7.69901118419740425e-03 #days f*
+4.99852801234917238e-03 #days f*
+2.37847173959480950e-03 #days f*
+1.62824170038242295e-03 #days f*
+coord: vy
+' vy .coord: .vy
+
+0e
+-6.90460016972063023e-05 #days f*
+2.30417297573763929e-05 #days f*
+-2.96589568540237556e-05 #days f*
+-9.51592254519715870e-05 #days f*
+coord: vz
+' vz .coord: .vz
+
+solarmass
+9.54791938424326609e-04 solarmass f*
+2.85885980666130812e-04 solarmass f*
+4.36624404335156298e-05 solarmass f*
+5.15138902046611451e-05 solarmass f*
+coord: mass
+' mass .coord: .mass
+
+
+fvariable px
+fvariable py
+fvariable pz
+
+: .p  px f? py f? pz f? ;
+: 0p  0e px f!  0e py f!  0e pz f! ;
+: p+  0p  nb 0 do I mass f@ fdup fdup  I vx f@ f* px f+!  I vy f@ f* py f+!  I vz f@ f* pz f+! loop ;
+: sun+  px f@ solarmass f/ fnegate 0 vx f!  py f@ solarmass f/ fnegate 0 vy f!  pz f@ solarmass f/ fnegate 0 vz f! ;
+: offp   p+ sun+ ;
+
 \
 \ GLOSSARY
 \ 
-\ buf                        Where to read the input.
-\ #buf                       Count of valid bytes in buf.
-\ readto    ( c -- )         Read the keys until C is read. Save keys in buf, C not included.
-\ off       ( n -- )         Given note N, set the offset for a line.
-\
 \ digit?    ( n -- f )       True if n is a digit.
 \
 \ inaddr                     Address of input string.
 \ #in                        Size of input string.
 \ in#                        Current index in input string.
 \ in?        ( -- f )        Does the input has any bytes to be consumed?
-\ lookb      ( -- c )        Look at the next byte in input.
+\ ina        ( -- a )        Current address of next byte in input string.
+\ lookb      ( -- c )        Look at the byte in outa.
 \ in+        ( -- )          Increment input index.
 \ inb        ( -- c )        Get next byte in input and increment input index.
 \
 \ #out                       Size of input string.
 \ out#                       Current index in output string.
 \ out?                       Does the output has room for a byte?
-\ outa                       Current output address.
+\ outa       ( -- a )        Current address of next byte in output string.
 \ outb                       Output byte to outa.
+\ s>out      ( a n -- )      Copy n bytes from a to outa.
 \
 \ nn                         Temporary storage for fret conversion.
 \ #nn                        Count of bytes in nn.
 \ >nn        ( -- )          Save fret number from input to nn, updating #nn.
-\ 
+\
+\ note?      ( c -- f )      True if c is a note.
+\ #ofb?      ( c -- f )      True if c is # or b.
+\ tune       ( 
 \ off                        Offset to be applied to frets.
 \ +off       ( -- )          Apply offset to number in nn.
 \
 \ parse      ( -- )          Parse all input, making the appropriate translations.
 \
 
+requires singlestep
+
+[DEBUG
 
 00 constant A
 01 constant A#
 10 constant G#
 11 constant Ab
 
-create #buf 0 c, 
-create buf 80 allot
-: get  buf 80 erase  buf 80 accept  #buf c! ;
-: readto  >r 0 begin key dup emit  r@ over <> while 
-  over buf + 1+ c! 1+ repeat drop r> drop buf c! ;
-
-: off  32 readto  buf find 0= if exit then  execute - ;
-
-
-create ss ," Ab|--------|-3b-0--12-3-3-|-3--0-------|---------------------------|"
-create stmp 255 allot  stmp 255 erase
-
-: digit?  [char] 0 [char] 9 1+ within ;
+10 constant nl
 
 create inaddr 0 ,
 create #in 0 ,
 create in# 0 ,
-: in?  in# @ #in @ < ;
+: in?  in# @ #in @ < dup 0= if abort" No more input" then ;
 : ina  inaddr @ in# @ + ;
-: lookb  ina c@ ;
+: lookb  ina c@ dup [char] T = if ." T" in# @ . space then ;
 : in+  1 in# +! ;
 : inb  lookb in+ ;
 
-create outaddr 0 ,			\ Address of output string
-create #out 0 ,				\ Size of output string
-create out# 0 ,				\ Current index in input string
+create outaddr 0 ,
+create #out 0 ,
+create out# 0 ,
 : out?  out# @ #out < ;
 : outa  outaddr @ out# @ + ;
 : outb  out? if outa c!  1 out# +! else abort" out of bounds" then ;
+: .out  outaddr @ #out @ type ;
+: s>out  >r outa r@ cmove  r> out# +! ;  \ todo: bounds checking
+
+: digit?  [char] 0 [char] 9 1+ within ;
 
 create #nn 0 c,
 create nn 0 c, 0 c,
 : >nn  inb nn c! 1 #nn c!  in? lookb digit? and if inb nn 1+ c! 2 #nn c! then ;
 
-
-: tune?  ( c -- f )  dup [char] A >=  swap [char] G <=  and ;
-: #orb?  ( c -- f )  dup [char] # =  swap [char] b = or ;
-
 \ We assume the a n describes a valid word and avoid the check.
 : >word  ( a n -- xt )  dup here dup >r ! 1 allot  here swap dup >r move r> allot  r> find drop ;
-: >tune  ( -- n )  lookb tune? if ina  in+ lookb #orb? if in+ 2 else 1 then  >word execute then ;
+
+: note?  ( c -- f )  dup [char] A >=  swap [char] G <=  and ;
+: #orb?  ( c -- f )  dup [char] # =  swap [char] b = or ;
+: tune  ( -- a n )  ina lookb note? if in+ lookb #orb? if in+ 2 else 1 then else 0 then ;
+: >tune  ( -- n | -1 )  tune dup if >word execute else -1 then ;
 
 create off 0 ,
 : +off  nn #nn c@ number  off @ + ;
 
 : n>s  0 <# #s #> ;
-: translate  >nn +off n>s dup >r outa swap cmove r>  out# +! ;
+: translate  >nn +off n>s s>out ;
 
-: parse  begin in? while lookb digit? if translate else inb outb then repeat ;
+: parse  begin in? lookb nl <> and while lookb digit? if translate else inb outb then repeat ;
 
+: /line  begin in? lookb nl <> and while inb outb repeat inb outb ;
+: phrase?  lookb note? if ina 1+ c@ dup #orb? if drop ina 2 + c@ then [char] | = else 0 then ;
+: phrase  begin phrase? while ." tune " tune ." s>out " s>out ." inb " inb ." outb " outb ." parse " parse ." line " /line repeat ;
+: >phrase  begin in? while phrase? if phrase then inb outb repeat ;
 
-2 off !
-ss count #in ! inaddr !
-stmp outaddr !  255 #out !
+: usage  argc 2 = if cr ." usage: " 0 argv type space 1 argv type ."  file" bye then ;
+: setfile  ( -- fileid )  
+  2 argv r/o open-file 0<> if ." Error opening file" bye then ;
+: setin  ( fileid -- )
+  dup >r file-size 0<> if ." Error getting file size" bye then 
+  d>s  here dup inaddr !  over allot over #in !  swap r@  over >r
+  read-file 0<> swap r> <> or if ." Error reading file" bye then r> close-file drop ;
+: setout  here dup outaddr !  #in @ 2 * dup #out !  dup allot erase ;
+: setup  setfile setin setout ;
+: .setup  cr ." File " 2 argv type cr
+  ." Input " inaddr @ . space #in @ .  in# @ . cr
+  ." Output " outaddr @ . space #out @ .  out# @ . cr ;
+
+DEBUG]