YaK:: FORTH Homework Assignment ( problems by Bill Ragsdale for SVFIG 2020-09-26 ) [Changes]   [Calendar]   [Search]   [Index]   [PhotoTags]   
[mega_changes]
[photos]

FORTH Homework Assignment ( problems by Bill Ragsdale for SVFIG 2020-09-26 )

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 )

1) Print the alphabet "AbCdEfGh . . . z" in alternating case using three methods.

Method One

$ 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.

Method Two

$ 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


Method Three

$ cat alphabet3.4th

: program
  13 0 do
      65 i + i + emit
      98 i + i + emit
  loop ;
cr program cr

$ gforth < alphabet3.4th
AbCdEfGhIjKlMnOpQrStUvWxYz
 ok

2) Print a table headed by 240 to 249 across with 170 to 179 down. At each intersection show the Greatest Common Divisor.

$ 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

3) Print the five largest prime numbers less than 10,000.

$ 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

4) Using numbers, terminal characters or graphics plot x-squared from 1 to 10.


$ 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------.

(unless otherwise marked) Copyright 2002-2014 YakPeople. All rights reserved.
(last modified 2020-09-26)       [Login]
(No back references.)