home *** CD-ROM | disk | FTP | other *** search
/ Shareware Overload / ShartewareOverload.cdr / progm / grafx.zip / WORM.FOR < prev   
Text File  |  1989-03-14  |  2KB  |  55 lines
  1. c    program main
  2. c    call gset                            !  enter graphic mode
  3. c    call worm
  4. c    call aset                            !  return to alpha mode
  5. c    end    
  6. c    -----------------------------------------------------------------------
  7.     subroutine worm
  8. c
  9.     real xc(100),yc(100)
  10.     integer*2 ich
  11.     integer tail
  12.     logical erase
  13. c
  14.     parameter (a2pi=6.283185307,atorad=a2pi/360.0)
  15.     parameter (nc=40,xmax=639.0,ymax=199.0)
  16. c
  17.     call window(0.0,0.0,xmax,ymax)
  18.     call view(0,0,639,199)
  19.     call putstr(10,20,' DEMONSTRATION OF COLOR TO ERASE')
  20.     call putstr(12,20,'  FOR A WHIMSICAL USAGE')
  21.     call pause('WHEN READY ')        !  display message and pause
  22.     call gcls
  23.     call atime(iseed)
  24.     call info(' NOW WATCH THE WORM:    HIT ANY KEY TO STOP ')
  25.     xnew=300.0
  26.     ynew=100.0
  27.     tail=1
  28.     erase=.false.                    !  flag to start erasing
  29.     dir=a2pi*rand(iseed)
  30.     deld=15.0*atorad
  31. c
  32. c    ...start of loop
  33. c
  34. 200    continue
  35.     call color('WHITE')                    !  set color on
  36.     call circle(xnew,ynew,4.0)            !  draw head
  37.     xc(tail)=xnew                        !  save it
  38.     yc(tail)=ynew
  39.     if(tail.eq.nc)erase=.true.            ! is worm full length ??
  40.     tail=mod(tail,nc)+1
  41.     dir=dir+sign(deld,rand(iseed)-0.5)        !  change direction
  42.     xnew=mod(xnew+6.0*cos(dir),xmax)
  43.     ynew=mod(ynew+2.0*sin(dir),ymax)
  44.     if(xnew.lt.0)xnew=xnew+xmax
  45.     if(ynew.lt.0)ynew=ynew+ymax
  46.     call color('BLACK')                    !  set color off
  47.     if(erase)call circle(xc(tail),yc(tail),4.0)        !  erase tail
  48.     call ckey(ich)                        !  stop when a key is pressed
  49.     if(ich.ne.0)goto 900
  50.     goto 200
  51. 900    continue
  52.     call color('WHITE')                    !  set color on
  53.     return
  54.     end
  55.