maryandleo

Tumbling in Albany, NY, USA

Posts tagged Forth Programming Language

Sep 15

My Final Program in Forth

\ missy.f  LW 20110915 +
\ Shows changes in a candidate’s database record over time.

INCLUDE string.txt

0 VALUE outfile
: out ( ca u ) outfile WRITE-FILE THROW ;
: lout ( ca u ) outfile WRITE-LINE THROW ;
: ?lout ( ca u ) -TRAILING ?DUP IF lout ELSE DROP THEN ;
: blout  PAD 0 lout ;

: 4dup  2OVER 2OVER ;
: 4drop  2DROP 2DROP ;
: under+ ( a b c - a+c b ) ROT + SWAP ;

0 VALUE dlist
: open-dlist
   S” dlist” R/O OPEN-FILE THROW TO dlist ;
: close-dlist
   dlist CLOSE-FILE THROW ;

: field ( a u — a’ )
   2DUP SWAP , , CHARS + ;
: ,field ( i n1 n2 ca u — i+1 n1+n2 )
   string, field 1 under+ ;

CREATE fields 0 0
 15  S” ID” ,field
 35  S” Name” ,field
 35  S” Street” ,field
 22  S” City State Zip” ,field
  2  S” County” ,field
  1  S” Vets” ,field
  1  S” Fee” ,field
 10  S” Home Phone” ,field
 10  S” Work Phone” ,field
  1  S” Status” ,field
 24  S” Course Work Line 1” ,field
 24  S” Course Work Line 2” ,field
 24  S” Course Work Line 3” ,field
 28  S” Legal Experience Line 1” ,field
 28  S” Legal Experience Line 2” ,field
 28  S” Legal Experience Line 3” ,field
 28  S” General Experience Line 1” ,field
 28  S” General Experience Line 2” ,field
 28  S” General Experience Line 3” ,field
 22  S” Other Education” ,field
 25  S” Legal Tasks” ,field
 50  S” Licences / Certifications” ,field
  1  S” Temp” ,field
  3  S” Appt Type” ,field
 14  S” Geo Areas” ,field
  8  S” Start Date” ,field
  8  S” End Date” ,field
 15  S” unused” ,field

CONSTANT rlen
CONSTANT nfields

: get-name ( i — ca u )
   fields SWAP
   0 ?DO COUNT CHARS + 2 CELLS + LOOP COUNT ;

: get-field ( ca1 i - ca2 u )
   get-name CHARS + 2@ under+ ;

22 CONSTANT fnlen
CREATE filename fnlen CHARS ALLOT
CREATE inpad rlen CHARS ALLOT
CREATE hand rlen CHARS ALLOT

CREATE ssn 9 CHARS ALLOT
: get-ssn
   CR .” Enter SSN:”
   SSN 9 ACCEPT 9 <>
   IF CR .” Bad SSN. The previous report will open.”
      5000 MS BYE
   THEN ;

: show-differences
   filename fnlen
   blout blout S” ><> ><> ><> ><> ><> ><> ><> ><> ” out
   2DUP supper out
   S”  <>< <>< <>< <>< <>< <>< <>< <><” lout
   nfields 1 DO
      inpad I get-field
      hand I get-field 4dup COMPARE
      IF
        I get-name blout out blout ?lout ?lout
      ELSE
        4drop
      THEN
   LOOP ;

: READS
   S” missy.txt” R/W CREATE-FILE THROW TO outfile
   S” SSN: ” out ssn 9 lout blout
   hand rlen BLANK
   CR .” Reading “
   BEGIN PAD DUP 84 DLIST READ-LINE THROW
   WHILE
     [CHAR] . EMIT
     S” candrec.2” SEARCH
     IF
       DROP fnlen 2DUP filename SWAP CMOVE
       R/O OPEN-FILE THROW >R
       4001 0 R@ REPOSITION-FILE THROW
       BEGIN inpad rlen R@ READ-FILE THROW
       WHILE
         inpad char+ 9 SSN 9 COMPARE 0=
           IF
             inpad rlen hand rlen COMPARE IF
               show-differences
               inpad hand rlen CMOVE
              THEN
           THEN    
       REPEAT
       R> CLOSE-FILE THROW
     ELSE
       2DROP
     THEN
   REPEAT 2DROP
   blout
   inpad rlen BLANK
   show-differences
   blout
   outfile CLOSE-FILE THROW ;

: fyj  get-ssn open-dlist reads close-dlist ;

fyj BYE


Jul 21

May 22

\ Conway’s Game of Life, or Occam’s Razor Dulled

MARKER Genesis

\ ANS Forth this life is remains and
1 CHARS CONSTANT /Char
: C+! ( char c-addr — ) DUP >R C@ + R> C! ;

\ the universal pattern
25 CONSTANT How-Deep
80 CONSTANT How-Wide
How-Wide How-Deep *
1- \ 1- prevents scrolling on my screen
CONSTANT Homes

\ world wrap
: World
CREATE ( — ) Homes CHARS ALLOT
DOES> ( u — c-addr )
SWAP Homes + Homes MOD CHARS + ;

World old
World new

\ biostatistics

\ begin hexadecimal numbering
HEX \ hex xy : x holds life , y holds neighbors count

10 CONSTANT Alive \ 0y = not alive

\ Conway’s rules:
\ a life depends on the number of
\ its next-door neighbors

\ it dies if it has fewer than 2 neighbors
: Lonely ( char — flag ) 12  ;

: -Sustaining ( char — flag )
DUP Lonely SWAP Crowded OR ;

\ it is born if it has exactly 3 neighbors
: Quickening ( char — flag )
03 = ;

\ back to decimal
DECIMAL

\ compass points
: N ( i — j ) How-Wide - ;
: S ( i — j ) How-Wide + ;
: E ( i — j ) 1+ ;
: W ( i — j ) 1- ;

\ census
: Home+! ( -1|1 i — ) >R Alive * R> new C+! ;

: Neighbors+! ( -1|0|1 i — )
2DUP N W new C+! 2DUP N new C+! 2DUP N E new C+!
2DUP W new C+! ( i ) 2DUP E new C+!
2DUP S W new C+! 2DUP S new C+! S E new C+! ;

: Bureau-of-Vital-Statistics ( -1|1 i — )
2DUP Home+! Neighbors+! ;

\ mortal coils
CHAR ? CONSTANT Soul
BL CONSTANT Body

\ at home
: Home ( char i — ) How-Wide /MOD AT-XY EMIT ;

\ changes, changes
: Is-Born ( i — )
Soul OVER Home
1 SWAP Bureau-of-Vital-Statistics ;
: Dies ( i — )
Body OVER Home
-1 SWAP Bureau-of-Vital-Statistics ;

\ the one and the many
: One ( c-addr — i )
0 old - /Char / ;
: Everything ( — )
0 old Homes
BEGIN DUP
WHILE OVER C@ DUP Alive AND
IF -Sustaining IF OVER One Dies THEN
ELSE Quickening IF OVER One Is-Born THEN THEN
1 /STRING
REPEAT 2DROP
How-Wide 1- How-Deep 1- AT-XY ;

\ in the beginning
: Void ( — )
0 old Homes BLANK ;

\ spirit
: Voice ( — c-addr u )
PAGE
.” Say: ” 0 new DUP Homes ACCEPT ;

\ subtlety
: Serpent ( — )
0 2 AT-XY
.” Press a key for knowledge.” KEY DROP
0 2 AT-XY
.” Press space to re-start, Esc to escape life.” ;

\ the primal state
: Innocence ( — )
Homes 0
DO I new C@ Alive / I Neighbors+! LOOP ;

\ children become parents
: Passes ( — ) 0 new 0 old Homes CMOVE ;

\ a garden
: Paradise ( c-addr u — )
>R How-Deep How-Wide *
How-Deep 2 MOD 0=
How-Wide AND -
R@ - 2/ old
R> CMOVE
0 old Homes 0
DO COUNT BL
DUP IF Soul I Home THEN
Alive AND I new C!
LOOP DROP
Serpent
Innocence Passes ;

: Creation ( — ) Void Voice Paradise ;

\ the human element

1000 VALUE Ideas
: Dreams ( — ) Ideas MS ;

1000 CONSTANT Images
: Meditation ( — ) Images MS ;

\ free will
: Action ( — char )
KEY? DUP
IF DROP KEY
DUP BL = IF Creation THEN
THEN ;

\ environmental dependence
27 CONSTANT Escape

\ history
: Goes-On ( — )
BEGIN Everything Passes
Dreams Action Meditation
Escape = UNTIL ;

\ a vision
: Life ( — ) Creation Goes-On ;

Life

\ 950724 + 970703 +

See Krishna Myneni, Of Poetry Life, and Computers.

May 11

A Forth program on tumblr

\ jason.f LW 21 Mar 2011, rev. 11 May 2011 +

\ input: xml

\ output: exam.txt, cand.txt

\ ANS Forth

include from.txt

from jenx.txt

0 value out1

0 value out2

: @move

  CREATE ( a n - a’ ) OVER , CHARS + 

  DOES> @ cbuff @+ ROT SWAP MOVE ;

CREATE outpad 258 CHARS ALLOT

outpad 9 @move /ssn

      20 @move /last-name

      15 @move /first-name

       1 @move /mi

      35 @move /street

      15 @move /city

       2 @move /state

       5 @move /zip

      10 @move /hphone

      10 @move /wphone

       1 @move /vets       \ will get from db

       2 @move /scredits   \ will get from db

       4 @move /prom-unit  \ will get from db

       5 @move /banded-te-score

       5 @move /raw-te-score

outpad - CONSTANT outlen

: opens 

   S” exam.txt” R/W CREATE-FILE THROW TO out1

   S” cand.txt” R/W CREATE-FILE THROW TO out2 ;

: closes

   out1 CLOSE-FILE THROW

   out2 CLOSE-FILE THROW ;

' -cBuff many: aliases lert-number exam-numbers

               agency agency-name

               agency-contact-name agency-contact-phone

               promotion-unit

               pref-area pref-appt-type pref-appt-duration

               bfoq1 bfoq2 ; DROP

' -cBuff many: aliases ssn first-name last-name mi street city

     state zip hphone wphone prom-unit

     banded-te-score raw-te-score ; DROP

: lout1

   cBuff @+ out1 WRITE-LINE THROW ;

' lout1 many: aliases /lert-number /exam-numbers

                      /agency /agency-name

                      /agency-contact-name /agency-contact-phone

                      /promotion-unit

                      /pref-area /pref-appt-type /pref-appt-duration

                      /bfoq1 /bfoq2 ; DROP

: lout2 ( outpad )

    outlen out2 WRITE-LINE THROW ;

: /ssn

    outpad outlen -TRAILING

    IF

       lout2 

    ELSE

       DROP

    THEN

    outpad outlen BLANK

    /ssn ;

: cls 25 0 DO CR LOOP  0 0 AT-XY ;

CREATE lertfile 128 CHARS ALLOT

: get-lert-file

    CR .” LERT: “

    PAD DUP 84 ACCEPT lertfile place

    S” .xml” lertfile append ;

opens

outpad outlen BLANK

cls

get-lert-file 

lertfile COUNT INCLUDED 

outpad lout2

closes

BYE