home *** CD-ROM | disk | FTP | other *** search
/ Simtel MSDOS 1992 June / SIMTEL_0692.cdr / msdos / forth / fifth.arc / FRAC.FIV < prev    next >
Text File  |  1986-05-27  |  3KB  |  142 lines
  1. CREATE FRAC
  2. CREATE MACHINE
  3. EDIT
  4. ( TI=0 / IBM=1 Machine flag)
  5. 0 constant machine
  6. ~UP
  7. CREATE XMAX
  8. CREATE X
  9. EDIT
  10. ( Maximum X for this machine)
  11. : x machine if 320 else 720 endif ;
  12. ~UP
  13. EDIT
  14. ( Maximum X value)
  15. x constant xmax
  16. ~UP
  17. CREATE YMAX
  18. CREATE Y
  19. EDIT
  20. : y machine if 200 else 300 endif ;
  21. ~UP
  22. EDIT
  23. y constant ymax
  24. ~UP
  25. CREATE GO
  26. CREATE GCLS
  27. EDIT
  28. : GCLS  4 vmode
  29.         0 0 0 xmax 1- ymax 1- FILLBOX
  30. ;
  31. ~UP
  32. CREATE ARRAY
  33. CREATE DEFINE
  34. EDIT
  35. : DEFINE  CREATE
  36.         16 1024 * ALLOT
  37.         DOES>
  38.         SWAP DUP 16384 U< IF ELSE ." Out of range, array" QUIT ENDIF
  39.         +
  40.  
  41. ;
  42. ~UP
  43. EDIT
  44. DEFINE ARRAY
  45. ~UP
  46. CREATE GENERATE
  47. CREATE TOP
  48. EDIT
  49. VARIABLE TOP
  50. ~UP
  51. EDIT
  52. : GENERATE
  53.         2 0 ARRAY C!
  54.         0 1 ARRAY C!            \ Changing the ARRAY initial values or
  55.         1 2 ARRAY C!            \
  56.         3 TOP !                 \ uncommenting this line and removing the
  57.                                 \ trailing +1 changes the pattern.
  58.         11 0 DO                 \  |
  59.              1  TOP @ 1- DO     \  |
  60.                 I ARRAY C@      \  V
  61.  (              J 3 AND IF 1+ ELSE 1- THEN 3 AND     ) 1+
  62.                 TOP @ ARRAY C! 1 TOP +!
  63.              -1 +LOOP
  64.         LOOP
  65. ;
  66. ~UP
  67. CREATE PLOT
  68. CREATE X
  69. EDIT
  70. VARIABLE X
  71. ~UP
  72. CREATE Y
  73. EDIT
  74. VARIABLE Y
  75. ~UP
  76. CREATE RR
  77. EDIT
  78. variable rr
  79. ~UP
  80. CREATE PREV
  81. EDIT
  82. : prev
  83.  
  84.         dup 0 = if  2 y +! drop exit endif
  85.         dup 1 = if -3 x +! drop exit endif
  86.             2 = if -2 y +!      exit endif
  87.                     3 x +!
  88. ;
  89. ~UP
  90. CREATE CURR
  91. CREATE L
  92. EDIT
  93. : L
  94.   stack ab|abab ymax u< swap xmax u< and if
  95.     else drop drop X @ Y @ exit endif
  96.  
  97.   moveto dup X @ Y @
  98.  
  99.   stack ab|abab ymax u< swap xmax u< and if
  100.      else stack abcde|de exit endif
  101.  
  102.   lineto point
  103. ;
  104. ~UP
  105. EDIT
  106. : CURR
  107.         dup 0 = if drop  2 y +!  L
  108.                          2 y +!  L exit endif
  109.         dup 1 = if drop -3 x +!  L
  110.                         -3 x +!  L exit endif
  111.             2 = if      -2 y +!  L
  112.                         -2 y +!  L exit endif
  113.                          3 x +!  L
  114.                          3 x +!  L
  115. ;
  116. ~UP
  117. EDIT
  118. ( Color Rotation -> )
  119. : PLOT
  120.         RR !                     ( Save rotation)
  121.         xmax 2/ X ! ymax 2/ Y !
  122.           x @ y @                ( Initial point, color on stack)
  123.                 1    array c@ rr @ + 3 and CURR
  124.         512 1 * 2 DO
  125.                 I 1- ARRAY C@ RR @ + 3 AND PREV
  126.                 I    ARRAY C@ RR @ + 3 AND CURR
  127.         LOOP drop drop drop
  128. ;
  129. ~UP
  130. EDIT
  131. : GO
  132.   cls gcls generate
  133.     99 0 do
  134.       ?term if abort endif
  135.       i [ 7 machine 4 * - ] literal mod 1+ i 3 and plot
  136.       loop
  137. ;
  138. ~UP
  139. EDIT
  140. : frac go ;
  141. ~UP
  142. ABORT