| YaK:: FORTH Homework Assignment ( problems by Bill Ragsdale for SVFIG 2020-09-26 ) | [Changes] [Calendar] [Search] [Index] [PhotoTags] |
|
Dear Forther,
You are invited to participate in a Forth Programming Challenge on Saturday, Sept. 26, 2020 as part of the monthly Silicon Valley Forth Interest Group meeting. This is not a contest, just show and tell. You are welcome to program solution(s) or just comment on any of the challenges.
When: Zoom meeting Sept. 26, 2020, 1:00 PM Pacific Daylight Time, 20:00 UTC. The Challenges: 1) Print the alphabet "AbCdEfGh . . . z" in alternating case using three methods. 2) Print a table headed by 240 to 249 across with 170 to 179 down. At each intersection show the Greatest Common Divisor. 3) Print the five largest prime numbers less than 10,000. 4) Using numbers, terminal characters or graphics plot x-squared from 1 to 10. Questions or suggestions: Bill Ragsdale |
Solutions by strick: ( also available at https://github.com/strickyak/forth-homework-2020-09-26 )
$ cat alphabet1.4th
\ Print alphabet in alternating case: AbCd...z ; strick for gforth
30000 constant SIZE
create tape SIZE cells allot \ The tape.
variable p \ Tape pointer.
: reset
tape p ! \ Initialize p to beginning of tape.
SIZE 0 do
0 i cells tape + ! \ Clear the tape.
loop ;
reset
: {-} - ; \ save - before redefining it.
: {+} + ; \ save + before redefining it.
: {.} . ; \ save . before redefining it.
: show \ show begining of tape, and pointer.
cr 10 0 do
i cells tape {+} p @ = if ." ^" then
i cells tape {+} @ {.}
loop cr ;
: - p @ @ 1 {-} p @ ! ; \ (*p)--;
: + p @ @ 1 {+} p @ ! ; \ (*p)++;
: . p @ @ emit ; \ putchar(*p);
: < p @ 1 cells {-} p ! ; \ p--;
: > p @ 1 cells {+} p ! ; \ p++;
: [ POSTPONE begin ; immediate
: ] POSTPONE p POSTPONE @ POSTPONE @
POSTPONE while
POSTPONE repeat ; immediate
: program
> > > + + + + [ < + + + + [ < + + + + [ < + > - ] > - ] > - ] < < < + show \ ^65
> + + + + + + + + + + + + + show \ 65 ^13 _
> > > > + + + + [ < + + + + + [ < + + + + + [ < + > - ] > - ] > - ] < < < - - < show \ 65 ^13 98
[
< . + + >
> . + + <
-
]
;
program
$ gforth < alphabet1.4th
^65 0 0 0 0 0 0 0 0 0
65 ^13 0 0 0 0 0 0 0 0
65 ^13 98 0 0 0 0 0 0 0
AbCdEfGhIjKlMnOpQrStUvWxYz ok
BTW, here is a web-based evaluator you can check my BF implementation with: https://sange.fi/esoteric/brainfuck/impl/interp/i.html
Paste everthing from ": program" to "; program" in the top right textarea, and hit "execute". Check my results against the bottom right textarea.
$ cat alphabet2.4th
\ Print alphabet in alternating case. strick for gforth
s" NoPqRsTuVwXyZaBcDeFgHiJkLm" \ pay no attention
constant MAGIC_LEN \ to that man
constant MAGIC_ADDR \ behind the curtain
13 constant M \ M is 13th letter of alphabet.
31 constant MASK \ Removes bits marking upper/lower/figs.
: rot13c ( char -- char )
dup MASK and M <= if
M else
M negate then
+ ;
: .rot13s ( addr len -- )
2dup
( addr len ) 0 do
( addr ) dup i + c@ rot13c emit
loop drop ;
cr cr MAGIC_ADDR MAGIC_LEN .rot13s cr
$ gforth < alphabet2.4th
AbCdEfGhIjKlMnOpQrStUvWxYz
ok
$ cat alphabet3.4th
: program
13 0 do
65 i + i + emit
98 i + i + emit
loop ;
cr program cr
$ gforth < alphabet3.4th
AbCdEfGhIjKlMnOpQrStUvWxYz
ok
$ cat gcd.4th
\ Problem 2: Print an gcd table. strick for gforth
: gcd ( a b -- z )
( a b ) dup 0 = if drop exit then
( a b ) over 0 = if swap drop exit then
( a b ) 2dup < if
( a b ) over mod recurse else
( a b ) dup rot swap mod recurse then
;
: 3d. \ fixed-length, print a 3 digit number and a space.
dup 100 >= if . exit then
dup 10 >= if ." " . exit then
." " .
;
: gcd-table cr
." : "
10 0 do i
240 i + 3d.
loop cr
10 0 do
170 i + 3d.
." : "
10 0 do
i 240 + j 170 + gcd 3d.
loop cr
loop cr
;
gcd-table
$ gforth < gcd.4th
: 240 241 242 243 244 245 246 247 248 249
170 : 10 1 2 1 2 5 2 1 2 1
171 : 3 1 1 9 1 1 3 19 1 3
172 : 4 1 2 1 4 1 2 1 4 1
173 : 1 1 1 1 1 1 1 1 1 1
174 : 6 1 2 3 2 1 6 1 2 3
175 : 5 1 1 1 1 35 1 1 1 1
176 : 16 1 22 1 4 1 2 1 8 1
177 : 3 1 1 3 1 1 3 1 1 3
178 : 2 1 2 1 2 1 2 1 2 1
179 : 1 1 1 1 1 1 1 1 1 1
ok
$ cat sieve.4th
\ Print 5 largest primes less than 10000. strick for gforth
10000 constant N \ limit of seive (exclusive)
5 constant K \ how many primes to print
1 constant TRUE
0 constant FALSE
create sieve N cells allot \ the array sieve
: top-primes
N 0 do FALSE sieve i cells + ! loop \ clear the sieve
N 2 / 2 do
N i 2 * ?do
TRUE sieve i cells + !
j +loop
loop
K
( k ) N 0 do \ loop forward, but meaning is backward: N 1 - i -
( k ) sieve N 1 - i - cells + @ FALSE = if
( K ) N 1 - i - . \ print the prime
( K ) 1 - \ decrement k
then
( k ) dup 0 = if drop leave then \ leave after printing 5 primes.
loop
;
top-primes
$ gforth < sieve.4th
9973 9967 9949 9941 9931 ok
$ cat square.4th
40 constant H \ screen height
72 constant W \ screen width
42 constant STAR
46 constant DOT
32 constant SP
124 constant VBAR
45 constant DASH
48 constant ZERO
: digit ( n -- ch ) ZERO + ; \ compute ascii digit
\ ---- screen graphics -----
create screen H W * cells allot
: set-char ( x y ch -- ) rot rot W * + cells screen + ! ;
: emit-char ( x y -- ch ) W * + cells screen + @ emit ;
: set-blank ( x y -- ) SP set-char ; \ actually '.' not ' '
: set-star ( x y -- ) 42 set-char ; \ sets '*'
: cls ( -- ) H 0 do W 0 do i j set-blank loop loop ;
: display ( -- ) cr H 0 do W 0 do i j emit-char loop cr loop ;
10000 constant XMAX000
100000 constant YMAX000
: draw-point-fixed-millis ( x000 y000 ch -- )
rot rot \ push char down to bottom
YMAX000 swap - \ flip screen so y000 increases bottom to top
H * YMAX000 / 0 max H 1 - min \ y -> integer from 0 to H
swap \ x on top
W * XMAX000 / 0 max W 1 - min \ x -> integer from 0 to W
swap \ y on top again
rot set-char ; \ recover the char & set it.
\ --------------------------
: draw-x-squared
XMAX000 0 do i i dup * 1000 / 35 draw-point-fixed-millis loop ;
: draw-x-axis
XMAX000 0 do i 0 45 draw-point-fixed-millis loop
YMAX000 0 do 11 1 do i 1000 * j DOT draw-point-fixed-millis loop loop
10 0 do i 1000 * 0 48 i + draw-point-fixed-millis loop ;
: draw-y-axis
YMAX000 0 do 0 i VBAR draw-point-fixed-millis loop
XMAX000 0 do 11 1 do j i 10 * 1000 * DOT draw-point-fixed-millis loop loop
10 0 do 0 i 10 * 1000 * i digit draw-point-fixed-millis loop \ first digit
10 0 do XMAX000 W / 1 + i 10 * 1000 * 0 digit draw-point-fixed-millis loop ; \ second digit
cls draw-x-axis draw-y-axis draw-x-squared display bye
$ gforth < square.4th
.......................................................................#
| . . . . . . . . . ##
| . . . . . . . . . ##.
| . . . . . . . . . ## .
90.................................................................##...
| . . . . . . . . . ## .
| . . . . . . . . .## .
| . . . . . . . . ## .
80.............................................................##.......
| . . . . . . . . ##. .
| . . . . . . . . ## . .
| . . . . . . . . ## . .
70.........................................................##...........
| . . . . . . . .## . .
| . . . . . . . ### . .
| . . . . . . . ##. . .
60....................................................##................
| . . . . . . . ## . . .
| . . . . . . . ## . . .
| . . . . . . ### . . .
50...............................................##.....................
| . . . . . . ##. . . .
| . . . . . . ### . . . .
| . . . . . . ## . . . .
40..........................................##..........................
| . . . . . ### . . . .
| . . . . . ##. . . . .
| . . . . . ### . . . . .
30...................................###................................
| . . . . ## . . . . .
| . . . . ### . . . . .
| . . . . ### . . . . . .
20............................###.......................................
| . . . #### . . . . . .
| . . . ###. . . . . . .
| . . .#### . . . . . . .
10.................####.................................................
| . . #### . . . . . . . .
| . ###### . . . . . . . .
############--2------3------4-------5------6------7------8------9------.
| (last modified 2020-09-26) [Login] |