home *** CD-ROM | disk | FTP | other *** search
/ SPACE 2 / SPACE - Library 2 - Volume 1.iso / program / 18 / forthsup / art.fth < prev    next >
Encoding:
Text File  |  1986-09-18  |  3.2 KB  |  135 lines
  1. \ String Art demo.  Load this file then type   stringart
  2. \ Typing any key stops the demo.
  3.  
  4. needs rnd random.fth
  5. needs line-a-init linea.fth
  6. line-a-init
  7.  
  8. decimal
  9.  
  10. 13 constant #functions
  11. 343 constant #artlines
  12.  
  13. #functions #artlines * constant #points
  14.  
  15. create function-points  #points /w*  allot
  16.  
  17. : random ( -- n )  #functions rnd   ;
  18.  
  19. \ Get a new random number that is different from the old one
  20. : new-rand ( old-rand -- new-rand )
  21.    begin  random  ( old new )
  22.           2dup =
  23.    while  drop
  24.    repeat
  25.    nip
  26. ;
  27.  
  28. : write-binary-points ( -- )
  29.    [""] stringpt.bin dup make drop
  30.    write open ofd !
  31.    function-points  #points /w*  ofd @ fputs
  32.    ofd @ close
  33. ;
  34. defer test ' noop is test
  35.  
  36. \ Read the ascii version of the function tables and write it back out
  37. \ as a binary file
  38. : read-points ( -- )
  39.    [""] stringpt.num read open ifd !
  40.    hex
  41.    function-points  #points /w*
  42.    bounds
  43.    ?do
  44.       pad ifd @ getword  test
  45.       number? 0= abort" bogus"
  46.       i w!
  47.    /w +loop
  48.    ifd @ close
  49.    write-binary-points
  50. ;
  51.  
  52. \ Read in the binary version of the function tables
  53. : read-binary-points ( -- )
  54.    [""] stringpt.bin read open ifd !
  55.    function-points  #points /w*  tuck ifd @  fgets
  56.        <> if ." Read failed" cr then
  57.    ifd @ close
  58. ;
  59. variable xs   variable ys      \ Starting endpoint for a line
  60. variable xe   variable ye      \ Ending   endpoint for a line
  61.  
  62. \ Find the starting address for the index'th function in the function
  63. \ table
  64. : >function ( index -- table-address )
  65.    #artlines * /w*  function-points +
  66. ;
  67.  
  68. \ Coefficients for transforming to the screen coordinate system
  69. wvariable xscale  wvariable yscale
  70. wvariable xoffset wvariable yoffset
  71. : set-scaling ( -- )
  72.    get-rez  ( xmax ymax )
  73.    2dup
  74.    9 10 */ yscale w!
  75.    9 10 */ xscale w!  ( xmax ymax )
  76.    20 / yoffset w!
  77.    20 / xoffset w!
  78. ;
  79. \ Transform normalized device coordinates to screen coordinates
  80. code ndc>device ( x y -- x' y' )
  81.    sp )+ d1 move  \ y
  82.    sp )+ d0 move  \ x
  83.    xscale l#)  d0   mulu
  84.    yscale l#)  d1   mulu
  85.    d0 d0 add
  86.    d1 d1 add
  87.    d0 word clr normal
  88.    d0 swap
  89.    d1 word clr normal
  90.    d1 swap
  91.    word xoffset l#) d0 add normal
  92.    word yoffset l#) d1 add normal
  93.    d0 sp -) move
  94.    d1 sp -) move
  95. c;
  96.  
  97. : nextw ( variable -- w )
  98.    dup @ w@ /w rot +!
  99. ;
  100. : draw-line ( -- )
  101.    xs nextw ys nextw  ndc>device ( startxy )
  102.    xe nextw ye nextw  ndc>device ( startxy endxy )
  103.    draw
  104. ;
  105. : string-drawing  ( xs xe  yx ye  -- )
  106.    >function ye !  >function ys !  >function xe !  >function xs !
  107.    #artlines 0  do  draw-line  loop
  108. ;
  109. : new-drawing  ( -- )
  110.        _fg_bp_1 w@  ( foreground-color )
  111.  
  112.        random dup  new-rand     ( color  xs xe )
  113.        random dup  new-rand     ( color  xs xe  ys ye )
  114.  
  115.        \ Draw with the foreground color
  116.        4dup  string-drawing     ( color  xs xe  ys ye )
  117.  
  118.        \ Erase by drawing with the background color
  119.        0 _fg_bp_1 w!
  120.        string-drawing           ( color )
  121.  
  122.        \ Restore the foreground color
  123.        _fg_bp_1 w!
  124. ;
  125. : stringart-setup  ( -- )
  126.    set-scaling
  127.    0 _wrt_mod w!
  128.    erase-screen
  129. ;
  130. : stringart  ( -- )
  131.    stringart-setup
  132.    begin  new-drawing   key? until
  133. ;
  134. read-binary-points
  135.