Beginning Programs in ANS Forth
Marker\ don't FORGET MARKER LEO \ greet the computer, and be greeted in turn : I'M ( -- ) \ usage: I'M <your name> 0 PARSE CR ." Hello, " TYPE CR ; \ miscellaneous tools : CHAR- ( a1 -- a2 ) 1 CHARS - ; : -ROT ( x y z -- z x y ) ROT ROT ; : UNDER+ ( x y z -- x+z y ) ROT + SWAP ; : INCR ( a -- ) 1 SWAP +! ; : BETWEEN ( n1 n2 n3 -- f ) 1+ WITHIN ; \ upper- lower-case conversions : UPPERCASE ( c -- C ) DUP [CHAR] a [CHAR] z BETWEEN BL AND XOR ; : lowercase ( C -- c ) DUP [CHAR] A [CHAR] Z BETWEEN BL AND XOR ; \ keyboard input : BIGKEY ( -- C ) KEY UPPERCASE ; : littlekey ( -- c ) KEY lowercase ; : STRING ( - pad u ) PAD DUP 84 ACCEPT -TRAILING ; : DOUBLE ( -- d f ) 0. STRING >NUMBER NIP 0= ; : INTEGER ( -- n ) DOUBLE DROP D>S ; \ convert a number to its ASCII representation \ after Moore : >DIGIT ( n -- c ) DUP 9 > 7 AND + [CHAR] 0 + ; \ display the following character \ a compile-only word : .CHAR ( '<spaces>name' -- ) POSTPONE [CHAR] POSTPONE EMIT ; IMMEDIATE \ square of n : SQUARED ( n -- n*n ) DUP * ; \ square root after Wil Baden \ see C. H. Ting, The First Course : SQRT ( n1 -- n2 ) 0 TUCK DO 1+ DUP 2* 1+ +LOOP ; \ sum of numbers from 1 to n : NSUM ( n -- sum ) DUP 1+ 2 */ ; \ random number generator from Brodie \ Starting Forth VARIABLE RND HERE RND ! : RANDOM ( -- u ) RND @ 31421 * 6927 + DUP RND ! ; : CHOOSE ( u - 0...u-1) RANDOM UM* NIP ; \ character array : CLIST CREATE ( u -- ) CHARS ALLOT DOES> ( u -- addr ) SWAP CHARS + ; \ size of an address unit, cell, character \ display the number of bits in an address unit \ see ANS Forth document for other query strings : BITS-IN-ADDRESS ( -- ) S" ADDRESS-UNITS-BITS" ENVIRONMENT? IF U. ELSE ." Query not answered." THEN ; \ show the number of address units in a cell : ADDRESSES-IN-CELL ( -- ) 0 CELL+ U. ; \ show the number of address units in a character : ADDRESSES-IN-CHAR ( -- ) 0 CHAR+ U. ; \ highest on-bit in x : HI-BIT ( x -- u ) 0 SWAP BEGIN DUP WHILE 1 RSHIFT 1 UNDER+ REPEAT DROP ; \ display the number of bits in a cell : BITS-IN-CELL ( -- ) TRUE HI-BIT U. ; \ display the number of bits in a character : BITS-IN-CHAR ( -- ) TRUE HERE C! HERE C@ HI-BIT U. ; \ Fahrenheit-Celsius conversion : F>C ( Fahrenheit -- Celsius ) 32 - 5 9 */ ; : C>F ( Celsius -- Fahrenheit ) 9 5 */ 32 + ; : FAHRENHEIT ( Fahrenheit -- ) ." is " F>C . ." Celsius. " ; : CELSIUS ( Celsius -- ) ." is " C>F . ." Fahrenheit. " ; \ Print Fahrenheit-Celsius table for fahr = 0, 20, ... 300 \ After Kernighan and Ritchie, \ The C Programming Language, 2nd ed. 0 CONSTANT lower \ lower limit of temperature table 300 CONSTANT upper \ upper limit 20 CONSTANT step \ step size : F>C ( Fahrenheit -- Celsius ) 32 - 5 9 */ ; : TABLE ( -- ) lower BEGIN DUP upper > 0= WHILE DUP CR 5 .R DUP F>C 5 .R step + REPEAT DROP ; \ Celsius to two decimal places : .2R ( n u -- ) >R DUP >R ABS 0 <# # # [CHAR] . HOLD #S R> SIGN #> R> OVER - SPACES TYPE ; : TABLE.2 lower BEGIN DUP upper > 0= WHILE DUP CR 5 .R SPACE DUP 32 - 500 9 */ 6 .2R step + REPEAT DROP ; Floating point version of table \ sum of the squares between two limits \ after Moore and Leach \ Forth - A Language for Interactive Computing \ (Mohasco Industries, Inc., 1970) : SUM-OF-SQUARES ( from to -- sum_of_squares ) 1+ 0 SWAP ROT DO I SQUARED + LOOP ; \ greatest common divisor \ Euclid's algorithm : UMOD ( u1 u2 - remainder) 0 SWAP UM/MOD DROP ; : GCD ( u1 u2 -- gcd ) BEGIN ?DUP WHILE TUCK UMOD REPEAT ; : GCD-RECURSIVE ( u1 u2 - gcd ) ?DUP IF TUCK UMOD RECURSE THEN ; \ Display the first 20 Fibonacci numbers : fibonacci ( -- ) 0 1 20 0 DO DUP . TUCK + LOOP 2DROP ; \ game of craps : WIN ( -- ) ." Win " ; : LOSE ( -- ) ." Lose " ; \ roll two dice \ ROLL and THROW already have meanings in Forth \ you can redefine any word but it's generally \ better not to : SHOOT ( -- 2...12 ) 6 CHOOSE 1+ 6 CHOOSE 1+ + DUP U. ; : NATURAL ( u - flag ) DUP 7 = SWAP 11 = OR ; \ three versions of a losing first throw \ which do you prefer and why? : CRAP ( u - flag ) DUP 2 = OVER 3 = OR SWAP 12 = OR ; : CRAP ( u - flag ) DUP 4 U< SWAP 12 = OR ; : CRAP ( u - flag ) 4 12 WITHIN 0= ; \ shoot for the point : POINT ( u -- ) BEGIN SHOOT 2DUP = IF DROP WIN ELSE 7 = IF LOSE ELSE FALSE THEN THEN UNTIL ; : CRAPS ( -- ) SHOOT DUP NATURAL IF WIN ELSE DUP CRAP IF LOSE ELSE DUP POINT THEN THEN DROP ; \ count words in a text file 128 CONSTANT MAXCHARS \ max characters in a line MAXCHARS 2 + CONSTANT MAXREAD CREATE LINEPAD MAXREAD CHARS ALLOT \ file words 0 VALUE FILE-ID : GET-FILE ( -- ) CR ." Filename:" STRING R/O OPEN-FILE ABORT" OPEN-FILE problem" TO FILE-ID ; : LINE ( -- a u flag ) LINEPAD DUP MAXREAD FILE-ID READ-LINE ABORT" READ-LINE problem" ; : DONE ( -- ) FILE-ID CLOSE-FILE ABORT" CLOSE-FILE problem" ; \ word-counting words \ skip leading white-space characters in ca1 u1 : SKIP-WHITE ( ca1 u1 -- ca2 u2 ) BEGIN DUP WHILE OVER C@ BL > 0= WHILE 1 /STRING REPEAT THEN ; \ skip leading non-white-space characters in ca1 u1 : SKIP-WORD ( ca1 u1 -- ca2 u2 ) BEGIN DUP WHILE OVER C@ BL > WHILE 1 /STRING REPEAT THEN ; \ count the words in a line \ the count is kept on the return stack : #WORDS ( a u1 -- u2 ) 0 >R BEGIN SKIP-WHITE DUP WHILE R> 1+ >R SKIP-WORD REPEAT 2DROP R> ; \ count the words in a file : COUNT-WORDS ( -- u ) 0 BEGIN LINE WHILE #WORDS + REPEAT 2DROP ; \ display the number of words in the file : .COUNT ( u -- ) CR U. ." words " ; : WC ( -- ) GET-FILE COUNT-WORDS .COUNT DONE ; \ prime numbers \ after Wirth, Programming in Modula-2, \ 2nd ed., p. 41 200 CONSTANT #PRIMES \ # of primes to compute 3 CONSTANT #KNOWN \ I know the first 3: 2 3 5 VARIABLE NOW \ a counter \ first so many primes are used to determine if \ a number is prime; these primes are stored \ the rest are just displayed #PRIMES SQRT CONSTANT YOUNG \ so Wirth CREATE YOUTH YOUNG CELLS ALLOT HERE CONSTANT OLD \ don't care about middle age \ display words : TITLE ( -- ) CR ." The first " #PRIMES U. ." prime numbers are:" CR ; : .PRIME ( u) 8 U.R ; \ display the first 3 primes : .KNOWN ( -- ) 2 .PRIME 3 .PRIME 5 .PRIME ; \ determine if a number is prime : PRIME ( u -- u remainder ) YOUTH BEGIN 2DUP @ TUCK /MOD ROT > OVER AND WHILE DROP CELL+ REPEAT NIP ; \ display prime number and increase counter : SAY ( u -- ) .PRIME NOW INCR ; \ if a young prime, store it in the array \ and update pointer : ?YOUNG ( a1 u -- a2 u ) OVER OLD U< IF SWAP 2DUP ! CELL+ SWAP THEN ; \ if it's prime, do some work : PRIME? ( a1 u -- a2 u ) PRIME IF DUP SAY ?YOUNG THEN ; \ skip multiples of 2 and 3 by alternately adding \ 2 or 4 to the previous candidate for prime : 2~4 ( 2|4 -- 4|2 ) 6 XOR ; : NEXT-CANDIDATE ( a1 u 2|4 -- a2 u+2|u+4 4|2 ) DUP >R + PRIME? R> 2~4 ; : PRIMES ( -- ) TITLE .KNOWN #KNOWN NOW ! 5 YOUTH ! YOUTH CELL+ \ skip 2 and 3 5 2 \ first candidate is 7 BEGIN NEXT-CANDIDATE NOW @ #PRIMES = UNTIL CR 2DROP DROP ; \ ANSified Sieve of Eratosthenes 8192 CONSTANT SIZE \ test this many odd numbers CREATE FLAGS SIZE CHARS ALLOT \ odd numbers HERE CONSTANT END-FLAGS \ address after the list : ODD ( u -- n) \ number n of flag u 2* 3 + ; 0 VALUE SIFT \ to sift or not to sift \ calculate offset of prime**2 : NEXT-SQUARE ( u1 -- u2 ) DUP SQUARED 2* SWAP 6 * + 3 + ; \ reset flags of multiples of a prime : RESET-FLAGS ( increment end-address start-address -- ) DO 0 I C! \ reset flag of an odd multiple DUP \ duplicate the loop increment +LOOP DROP ; : SIEVE ( -- ) FLAGS SIZE 1 FILL \ assume numbers are prime TRUE TO SIFT \ yes to sifting 0 \ 0 the count of primes FLAGS \ start with first flag SIZE 0 DO \ outer loop COUNT IF \ prime? ; address now next flag 1 UNDER+ \ add 1 to the count of primes SIFT IF I NEXT-SQUARE DUP SIZE U< IF \ next square in array? I ODD CHARS \ loop increment END-FLAGS \ loop end ROT CHARS FLAGS + \ loop start RESET-FLAGS \ inner loop ELSE DROP FALSE TO SIFT THEN THEN THEN LOOP DROP U. ." Primes" ; \ test : .PRIMES ( -- ) CR 0 FLAGS SIZE 0 DO COUNT IF I ODD .PRIME 1 UNDER+ THEN LOOP DROP CR U. ." prime numbers displayed. " ; : SIEVE-TEST ( -- ) SIEVE .PRIMES ; \ powers of 2 after Wirth \ Programming in Modula-2, 2nd ed., pp. 37-39 32 CONSTANT #EXPONENTS 10 CONSTANT +PLACES \ enough for 2&32 VARIABLE +PLACE \ digits for 2^n CREATE +DIGITS +PLACES CHARS ALLOT CREATE -DIGITS #EXPONENTS CHARS ALLOT \ display a digit sans trailing blank : .DIGIT ( u -- ) 1 U.R ; \ a positive power is calculated... : +POWER ( -- ) 0 +DIGITS \ starting carry, address +PLACE @ 0 DO >R \ address R@ C@ 2* + DUP 9 > TUCK \ flag for digit and carry 10 AND - R@ C! \ store digit 1 AND \ new carry R> CHAR+ \ next address LOOP DROP IF +PLACE INCR THEN ; \ ...then displayed : .+POWER ( -- ) +PLACE @ +PLACES OVER - SPACES DUP CHARS +DIGITS + SWAP 0 DO CHAR- DUP C@ .DIGIT LOOP DROP ; \ a negative power is displayed as it is calculated : -POWER ( u -- ) ." 0." 1- \ divide u-1 times for the 1st u-1 digits 0 -DIGITS \ starting remainder, address ROT 0 ?DO >R \ address 10 * R@ C@ + DUP 2/ \ next digit DUP .DIGIT R@ C! \ show it, store it 1 AND \ new remainder R> CHAR+ \ next address LOOP 2DROP 5 .DIGIT \ last digit always 5 ; : POWERS-OF-2 ( -- ) 1 0 +DIGITS C! 1 +PLACE ! #EXPONENTS 1+ 1 DO CR +POWER .+POWER I 4 U.R 2 SPACES I -POWER LOOP ; : P2 ( -- ) POWERS-OF-2 ; \ fractions after Wirth \ Programming in Modula-2, 2nd ed., pp. 40-41 \ data structures DECIMAL 32 CONSTANT MAXDIVISOR 0 VALUE DIVISOR \ will go from 2 to maxdivisor MAXDIVISOR CLIST DIGIT \ digits in the fraction MAXDIVISOR CLIST INDEX \ index of remainders \ display words : .DIVISOR ( -- ) CR DIVISOR 4 U.R 2 SPACES ; : .FRACTION ( #digits index[repeated-remainder] -- ) 1- \ number of digits to repeating period ." 0." \ integer part 1 DIGIT OVER TYPE \ digits before repeats .CHAR ' \ period marker DUP 1+ DIGIT -ROT - TYPE \ repeating period SPACE ; : FRACTIONS ( -- ) MAXDIVISOR 1+ 2 DO I TO DIVISOR .DIVISOR 0 INDEX DIVISOR 0 FILL \ for new divisor 0 1 \ #digits, remainder BEGIN 1 UNDER+ \ increment #digits 2DUP INDEX C! \ #digits in \ index(remainder) 10 * DIVISOR /MOD \ compute next digit, remainder >DIGIT ROT TUCK DIGIT C! \ store ASCII version SWAP DUP INDEX C@ \ index(remainder) ?DUP UNTIL \ done if \ remainder occurred before NIP \ discard remainder .FRACTION LOOP ; \ GUESS after Kemeny & Kurtz \ Back to BASIC, pp. 114-119 \ range of numbers to guess from 1 CONSTANT LOWEST 100 CONSTANT HIGHEST : INSTRUCTIONS ( -- ) PAGE ." You and the machine take turns." CR ." One player chooses an integer from " LOWEST . ." to " HIGHEST . ." ." CR ." The other player must guess the number." CR ." After each guess a hint is given:" CR ." 'Smaller' , 'Larger' , or 'Correct' ." CR ." The player needing fewer guesses wins." CR ; : SEED ( -- ) TIME&DATE + + + + + 0 DO RANDOM DROP LOOP ; : RANDOM-INTEGER ( n1 n2 -- n1...n2 ) 1+ OVER - CHOOSE + ; \ game variables VARIABLE YOUR-GUESSES VARIABLE MACHINE'S-GUESSES VARIABLE YOUR-WINS VARIABLE MACHINE'S-WINS VARIABLE TIES : ZERO ( a -- ) 0 SWAP ! ; : START-EVEN ( -- ) YOUR-WINS ZERO MACHINE'S-WINS ZERO TIES ZERO ; \ your turn : MACHINE-CHOOSES ( -- n ) LOWEST HIGHEST RANDOM-INTEGER CR ." A number has been chosen." CR ; : YOU ( -- ) MACHINE-CHOOSES YOUR-GUESSES ZERO BEGIN ." Your guess: " INTEGER CR YOUR-GUESSES INCR OVER - DUP WHILE 0< IF ." Larger." ELSE ." Smaller." THEN CR REPEAT 2DROP ." Correct!" CR ." You needed " YOUR-GUESSES ? ." guesses." CR ; \ the machine's turn VARIABLE LOW VARIABLE HIGH VARIABLE CORRECT : MODERATE ( n1 n2 -- n3 ) 2* + 3 / ; : MACHINE'S-GUESS ( -- n ) LOW @ HIGH @ 2DUP SWAP MODERATE -ROT MODERATE RANDOM-INTEGER DUP ." The machine guesses " . CR MACHINE'S-GUESSES INCR ; : YOUR-ANSWER ( machine's-guess -- ) BEGIN ." Hint ( Larger, Smaller, Correct ) " BIGKEY DUP [CHAR] L = IF ." Larger" SWAP 1+ LOW ! ELSE DUP [CHAR] S = IF ." Smaller" SWAP 1- HIGH ! ELSE DUP [CHAR] C = IF ." Correct" NIP TRUE CORRECT ! ELSE FALSE AND CR ." Please answer S , L , or C ." THEN THEN THEN CR UNTIL ; : IMPOSSIBLE ( -- f ) LOW @ HIGH @ > DUP IF ." That cannot be." CR MACHINE'S-GUESSES ZERO THEN ; : MACHINE'S-GUESSING ( -- ) LOWEST LOW ! HIGHEST HIGH ! FALSE CORRECT ! BEGIN MACHINE'S-GUESS YOUR-ANSWER CORRECT @ IMPOSSIBLE OR UNTIL ; \ wait for a key press : WAIT ( -- ) KEY DROP ; : MACHINE ( -- ) ." Your turn to think of a number." CR ." Press a key when ready..." WAIT CR MACHINE'S-GUESSES ZERO MACHINE'S-GUESSING MACHINE'S-GUESSES @ ?DUP IF ." The machine needed " . ." guesses." ELSE ." You cheated." THEN CR ; \ who won : YOU-OR-IT ( -- ) YOUR-GUESSES @ MACHINE'S-GUESSES @ - DUP 0< IF ." You won." YOUR-WINS INCR ELSE DUP IF ." The machine won." MACHINE'S-WINS INCR ELSE ." It's a tie." TIES INCR THEN THEN CR DROP ; : ENOUGH ( -- ) ." Another game (y/n)?" BIGKEY CR [CHAR] Y <> ; : RESULTS ( -- ) ." Your score: " YOUR-WINS ? CR ." The machine's score: " MACHINE'S-WINS ? CR ." Ties: " TIES ? CR ; \ the game : GUESS ( -- ) SEED INSTRUCTIONS START-EVEN BEGIN YOU MACHINE YOU-OR-IT ENOUGH UNTIL RESULTS ; \ Permute after Wirth \ Programming in Modula 2, 2nd ed., pp. 54-55 \ uses pad instead of a named array of characters 0 VALUE #LETTERS : LETTERS ( a -- a u ) \ usage: <addr> LETTERS <characters> BL PARSE TO #LETTERS CR OVER #LETTERS CMOVE #LETTERS ; : .LETTERS ( a -- ) #LETTERS TYPE SPACE ; : CPAIR ( a n1 n2 -- a1 a2 ) CHARS >R OVER CHARS + SWAP R> + ; : CTRADE ( a1 a2 -- ) 2DUP C@ -ROT C@ SWAP C! SWAP C! ; : (PERMUTE) ( a n -- ) 1- ?DUP IF 2DUP RECURSE DUP 0 DO 2DUP I CPAIR CTRADE 2DUP RECURSE 2DUP I CPAIR CTRADE LOOP 2DROP ELSE .LETTERS THEN ; : PERMUTE ( -- ) \ usage: PERMUTE <characters> PAD LETTERS (PERMUTE) ; \ postfix after Wirth \ Programming in Modula 2, 2nd ed., pp. 56-57 \ Windows(TM)98 - not!! : QUICK-AND-DIRTY-WINDOW CREATE ( left top right bottom -- ) , , 2DUP , , , , ; 0 0 25 20 QUICK-AND-DIRTY-WINDOW 0WINDOW 30 0 55 20 QUICK-AND-DIRTY-WINDOW 1WINDOW : LEFT-TOP ( a -- col row ) CELL+ CELL+ 2@ ; : TOP ( a -- row ) LEFT-TOP NIP ; : LEFT ( a - col ) LEFT-TOP DROP ; : RIGHT-BOTTOM ( a -- col row ) 2@ ; : BOTTOM ( a -- row ) RIGHT-BOTTOM NIP ; : RIGHT ( a -- col ) RIGHT-BOTTOM DROP ; : XY ( a1 -- a2) 4 CELLS + ; 0 VALUE WIDE : WPAGE ( a -- ) >R R@ LEFT-TOP AT-XY R@ RIGHT R@ LEFT - 1+ TO WIDE R@ LEFT-TOP R@ BOTTOM 1+ SWAP DO DUP I AT-XY WIDE SPACES LOOP DROP R@ LEFT-TOP 2DUP R@ XY 2! AT-XY R> DROP ; : WCR ( a -- ) >R R@ LEFT R@ XY 2@ NIP 1+ R@ BOTTOM MIN 2DUP AT-XY R@ XY 2! R> DROP ; : WEMIT ( c a -- ) >R R@ XY 2@ AT-XY EMIT R@ XY 2@ SWAP 1+ R@ RIGHT MIN SWAP R@ XY 2! R> DROP ; \ implementation dependent? 13 CONSTANT InputReturnKey 0 VALUE EXPRESSION \ expression defined below : FACTOR ( c1 -- c2 ) DUP [CHAR] ( = IF 0WINDOW WEMIT littlekey EXPRESSION EXECUTE BEGIN DUP [CHAR] ) <> WHILE DROP littlekey REPEAT ELSE DUP [CHAR] [ = IF 0WINDOW WEMIT littlekey EXPRESSION EXECUTE BEGIN DUP [CHAR] ] <> WHILE DROP littlekey REPEAT ELSE BEGIN DUP [CHAR] a < OVER [CHAR] z > OR WHILE DROP littlekey REPEAT DUP 1WINDOW WEMIT THEN THEN 0WINDOW WEMIT littlekey ; : TERM ( c1 -- c2 ) FACTOR BEGIN DUP [CHAR] * = OVER [CHAR] / = OR WHILE DUP >R 0WINDOW WEMIT littlekey FACTOR R> 1WINDOW WEMIT REPEAT ; :NONAME ( c1 -- c2 ) TERM BEGIN DUP [CHAR] + = OVER [CHAR] - = OR WHILE DUP >R 0WINDOW WEMIT littlekey TERM R> 1WINDOW WEMIT REPEAT ; TO EXPRESSION : POSTFIX ( -- ) 0WINDOW WPAGE 1WINDOW WPAGE BEGIN [CHAR] > 0WINDOW WEMIT littlekey DUP InputReturnKey <> WHILE EXPRESSION EXECUTE 0WINDOW WCR 1WINDOW WCR DROP REPEAT DROP ; \ Queens after Wirth \ Programming in Modula 2, 2nd ed., pp. 57-59 \ Wirth uses screen painting 80 CONSTANT SCREEN-COLUMNS 25 CONSTANT SCREEN-ROWS 0 VALUE LEFT \ screen location 0 VALUE TOP \ screen location \ maximum number of columns/rows SCREEN-COLUMNS SCREEN-ROWS MIN 1- 2/ CONSTANT NMAX 0 VALUE N \ actual number of columns/rows VARIABLE ANSWERS \ number of "solutions" \ pause half a second : PAUSE ( -- ) 500 MS ; : PEACE ( -- ) ANSWERS INCR 0 0 AT-XY N . ." QUEENS " ANSWERS ? ." ANSWERS" PAUSE ; : DASHES ( n -- ) 0 DO ." +---" LOOP .CHAR + ; : GAPS ( n -- ) 0 DO .CHAR | 3 SPACES LOOP .CHAR | ; : .BOARD ( -- ) PAGE N 0 DO LEFT TOP I 2* + 2DUP AT-XY N DASHES 1+ AT-XY N GAPS LOOP LEFT TOP N 2* + AT-XY N DASHES PEACE ; : AT-BOARD ( col row -- ) 2* 1+ TOP + >R 4 * 2 + LEFT + R> AT-XY ; \ Wirth uses Boolean arrays NMAX CLIST ROW : /DIAGONALS \ lower left to upper right CREATE ( u -- ) CHARS ALLOT DOES> ( col row -- a ) >R + CHARS R> + ; NMAX 2* 1- /DIAGONALS /DIAGONAL : \DIAGONALS \ upper left to lower right CREATE ( u -- ) CHARS ALLOT DOES> ( col row -- a ) >R - N 1- + CHARS R> + ; NMAX 2* 1- \DIAGONALS \DIAGONAL 0 VALUE SAFE? : >ARRAYS ( col row -- ) DUP ROW SAFE? SWAP C! 2DUP /DIAGONAL SAFE? SWAP C! \DIAGONAL SAFE? SWAP C! ; : PUT ( col row -- ) FALSE TO SAFE? \ a queen creates danger 2DUP >ARRAYS AT-BOARD .CHAR Q ; : PUNT ( col row -- ) TRUE TO SAFE? \ removing her lessens danger 2DUP >ARRAYS AT-BOARD SPACE ; : -QUEENS ( -- ) TRUE TO SAFE? 0 ROW N SAFE? FILL 0 0 /DIAGONAL N 2* 1- SAFE? FILL 0 N 1- \DIAGONAL N 2* 1- SAFE? FILL ; : BOARD ( -- ) -QUEENS .BOARD ; : SAFE ( col row -- flag) DUP ROW C@ >R 2DUP /DIAGONAL C@ >R \DIAGONAL C@ R> R> AND AND ; : TRY-COLUMN ( col -- ) N 0 DO I ( col row ) 2DUP SAFE IF 2DUP PUT \ install queen OVER IF OVER 1- RECURSE ELSE PEACE THEN 2DUP PUNT \ remove queen THEN DROP LOOP DROP ; \ starting values : VALUES ( n -- ) 1 MAX NMAX MIN TO N SCREEN-COLUMNS 1- 2/ N 2* - TO LEFT SCREEN-ROWS 1- 2/ N - TO TOP -1 ANSWERS ! ; : (QUEENS) ( n -- ) VALUES BOARD N 1- TRY-COLUMN ; : 8QUEENS ( -- ) 8 (QUEENS) ; : QUEENS ( -- ) NMAX 0 DO I 1+ (QUEENS) LOOP ; \ 99 Bottles of Beer \ after Wil Baden \ See also: 99 Bottles of Beer in Froth : BOTTLES ( n -- ) DUP CR . ." bottles of beer on the wall," DUP CR . ." bottles of beer," CR ." Take one down and pass it around." 1- CR . ." bottles of beer on the wall." CR ; : UNTIL-3 ( n -- ) 3 TUCK MAX DO I BOTTLES -1 +LOOP ; : TWO ( -- ) CR ." Two bottles of beer on the wall," CR ." Two bottles of beer," CR ." Take one down and pass it around," CR ." One bottle of beer on the wall." CR ; : ONE ( -- ) CR ." One bottle of beer on the wall," CR ." One bottle of beer," CR ." Take it down and pass it around," CR ." No more bottles of beer on the wall." CR ; : NONE ( -- ) CR ." No more bottles of beer on the wall," CR ." No more bottles of beer," CR ." Go to the store and buy some more," CR ." 99 bottles of beer on the wall." CR ; : SONG ( -- ) 99 UNTIL-3 TWO ONE NONE ; \ Christmas Tree \ After a challenge by Gordon Charlton 24 Nov 1999 + 32 CONSTANT center : emit+ ( message beyond a1 -- m b a2 ) COUNT EMIT 2DUP = IF DROP OVER THEN ; : level ( m b a1 level -- m b a2 ) CR center OVER - SPACES 2* 1+ 0 ?DO emit+ LOOP ; : levels ( m b a1 levels -- m b a2 ) 0 ?DO I level LOOP ; : tree \ <message> ( levels -- ) >R 0 PARSE OVER CHARS + OVER PAGE \ clear screen R> levels \ boughs 1 level 1 level 1 level \ trunk 4 level 4 level 4 level 4 level \ pot 2DROP DROP ; 16 tree a*very*merry*christmas*to*all*my*customers* \ Search and Replace All \ In string ca1 u1, replace every ca2 u2 with ca3 u3 \ The buffer at ca1 must be large enough \ to hold the resulting string : s/r ( ca1 u1 ca2 u2 ca3 u3 -- ca1 u4 ) 2>R R@ OVER - >R 2OVER BEGIN 2OVER DUP >R SEARCH WHILE 2DUP R> /STRING SWAP DUP R@ CHARS + ROT CHARS MOVE R@ + OVER R> SWAP 2R@ ROT SWAP CMOVE R@ SWAP >R /STRING REPEAT 2R> 2DROP 2R> 2DROP CHARS + NIP NIP NIP OVER - 1 CHARS / ; : praise ( -- ) S" hohoho" PAD SWAP 2DUP 2>R CMOVE 2R> S" ho" S" Holy " s/r TYPE ; \ Zeller's Congruence \ From day month year, calculate the day of the week : fmod ( n1 n2 -- floored-mod ) >R S>D R> FM/MOD DROP ; : dow ( d m ccyy -- 0=Sunday...6=Saturday ) \ Make year begin in March >R 2 - DUP 1 < IF 12 + R> 1- >R THEN R> \ Separate ccyy into yy and cc 100 /MOD 2>R ( d m ) ( R: yy cc ) \ Zeller's Congruence: \ dow = (d + (26*m - 2)/10 + cc/4 - 2*cc + yy/4 + yy) mod 7 26 * 2 - 10 / + \ d + (26*m - 2)/10 R@ 4 / + R> 2* - \ + cc/4 - 2*cc R@ 4 / + R> + \ + yy/4 + yy 7 fmod ; \ mod 7 = dow : today ( -- ) TIME&DATE dow NIP NIP NIP ." is " DUP 0= IF ." Sun" ELSE DUP 1 = IF ." Mon" ELSE DUP 2 = IF ." Tues" ELSE DUP 3 = IF ." Wednes" ELSE DUP 4 = IF ." Thurs" ELSE DUP 5 = IF ." Fri" ELSE ." Satur" THEN THEN THEN THEN THEN THEN DROP ." day." ; \ Some floating-point programs \ miscellaneous floating-point tools : -FROT ( r1 r2 r3 -- r3 r1 r2 ) FROT FROT ; : FTUCK ( r1 r2 -- r2 r1 r2 ) FSWAP FOVER ; : FSWOOP ( r1 r2 -- r2 r1 r1 ) FSWAP FDUP ; : FSPIN ( r1 r2 r3 -- r3 r2 r1 ) FSWAP FROT ; : FSQUARED ( r -- r**2 ) FDUP F* ; : FHALVED ( r -- r/2 ) .5E F* ; : FLOAT ( -- r ) STRING >FLOAT 0= ABORT" Not a floating point number" ; \ display words : ?SIGN ( flag -- ) IF [CHAR] - EMIT THEN ; : ?POINT ( flag -- ) IF [CHAR] . EMIT THEN ; : ZEROES ( n -- ) 0 MAX 0 ?DO [CHAR] 0 EMIT LOOP ; : 0.ZEROES ( d n -- ) ." 0." NEGATE MIN ZEROES ; \ display a floating point number \ right aligned in a field : F.R ( width decimal-places -- ) ( F: r -- ) >R >R PAD PRECISION REPRESENT 0= ABORT" out of range" OVER 0> IF 2DUP R> + R@ - SWAP - 1+ SPACES ?SIGN PAD OVER TYPE R@ ?POINT PAD + R> TYPE ELSE R> R@ - 1+ SPACES ?SIGN R@ OVER 0.ZEROES R> + PAD SWAP 0 MAX TYPE THEN ; \ left aligned : F.D ( decimal-places -- ) ( F: r -- ) 0 SWAP F.R ; \ print Fahrenheit-Celsius table for fahr = 0, 20, ... 300 \ floating point version with DO ... LOOP \ after Kernighan and Ritchie 0 CONSTANT lower \ lower limit of temperature table 300 CONSTANT upper \ upper limit 20 CONSTANT step \ step size 5E 9E F/ FCONSTANT 5/9 : S>F ( n -- ) ( F: -- r ) S>D D>F ; : TABLE.F ( -- ) lower upper over - step / 1+ 0 ?DO DUP CR 3 .R DUP 32 - S>F 5/9 F* 6 2 F.R step + LOOP DROP ; Integer versions of table
\ pi after Kemeny and Kurtz \ Back to BASIC, pp. 107-110. : MUCH-LIKE-PI ( -- f ) CR ." Making pi:" 2.0E \ a = 2 1.0E 2.0E FSQRT F/ \ h = 1/sqrt(2) 24 0 DO FTUCK F/ \ a = a/h FTUCK CR F. \ display a 1.0E F+ 2.0E F/ FSQRT \ h = sqrt((1+h)/2) LOOP FDROP ; MUCH-LIKE-PI FCONSTANT PI \ power after Wirth \ Programming in Modula 2, 2nd ed., p. 22. \ note that the ANS Forth floating-point extension \ words include F** ( r1 r2 -- r1**r2 ) : (POWER) ( x i -- x**i ) \ x float, i cardinal >R 1.0E FSWAP R> ( z x i ) BEGIN DUP WHILE \ while i > 0 2 /MOD >R \ push i=i/2 IF FTUCK F* FSWAP THEN \ if i odd z=z*x FSQUARED \ x=x*x R> \ pop i REPEAT DROP \ drop i=0 FDROP ; \ drop x, leaving z=x**i : POWER ( -- ) BEGIN ." x = " FLOAT FDUP F0= 0= WHILE ." i = " INTEGER 0 MAX (POWER) ." x**i = " F. CR REPEAT FDROP ; \ log2 after Wirth \ Programming in Modula 2, 2nd ed., p. 22. 1E-7 FCONSTANT TINY : (LOG2) ( 1.0<=r1<2.0 -- r2 ) 0E FSWAP 1.0E ( sum a b ) BEGIN FHALVED ( sum a b=b/2 ) FSWAP ( sum b a ) FSQUARED ( sum b a=a**2 ) FDUP ( sum b a a ) 2.0E F< 0= IF ( sum b a f ) FHALVED ( sum b a=a/2 ) -FROT ( a sum b ) FTUCK ( a b sum b ) F+ ( a b sum=sum+b ) FSPIN ( sum b a ) THEN FSWOOP ( sum a b b ) TINY F< UNTIL ( sum a b ) FDROP FDROP ; : LOG2 ( -- ) BEGIN ." x = " FLOAT FDUP 1.0E F< 0= >R FDUP 2.0E F< R> AND WHILE (LOG2) ." log2 = " F. CR REPEAT FDROP ; \ test for Pentium bug \ after Thomas Koenig : BUG? ( -- ) 4195835.0E 3145727.0E FOVER FOVER F/ F* F- FDUP ." Returned " F. F0= IF ." No " THEN ." Bug!" ; \ 28Aug96 + 05Mar97 + 03Jun97 + 03Dec97 + 13Jan98 + \ 27Jan98 + 31Jan98 + 15Mar99 + 24Nov99 + 07Jan00 + \ 14Jan00 + 27Nov00 + 03Jan01 + 04Dec02 +
Leo Wong hello@albany.net