Subject: FERN.BAS
 
 
'  FERN.BAS
 
'  This program was written for CPS 575 - Computer Graphics at CMU.  Matrices
' provided by H. Bidasarria (with little to no explanation on how they were
' derived).  Any questions or comments about the program may be directed to
' Mark Brown <347ndr5@cmuvm>.  (As was stated, there was little explanation on
' how these matrices were derived - Please do not ask how to turn the leaf into
' a tree.  I haven't the slightest idea.)
 
RANDOMIZE TIMER
 
'INPUT"Percent chance for trans #1 :",t1        Might try with new
'INPUT"Percent chance for trans #2 :",t2            percentages for fun...
'INPUT"Percent chance for trans #3 :",t3
'INPUT"Percent chance for trans #4 :",t4
 
t1=.01:t2=.85:t3=.07:t4=.07      ' Actual percentages for occurance of each
                                 ' matrix.
 
scx=52.5 : scy=17.5              ' A scaling factor for screen
                                 ' for (640,200) screen
 
depth=4                          ' For depth of screen (defines colors allowed)
SCREEN 2,640,200,depth,2         ' Set up screen.
WINDOW 2,,,16,2                  ' Set up a window.
mc=2^depth-1                     ' mc=Maxcolors
 
PALETTE 0,0,0,0
FOR i=1 TO 8                     ' set up 8 shades of green
   PALETTE i,0,(i+7)/15,0
NEXT i
 
COLOR 15,0                       ' clear screen, background black, fore green
CLS
 
x=0: y=0
 
start:
   a$=INKEY$
   IF a$="q" THEN thesaver        ' if press q then save pic
 
   col=(6*RND)+1                  ' pick random shade of green
   tran = RND
   IF tran<= t1 THEN trn1        ' decide from percentiles, which transformation
   IF tran<= t1+t2 THEN trn2
   IF tran<= t1+t2+t3 THEN trn3
   GOTO trn4
 
part2:
   IF ct<100 THEN ct=ct+1:GOTO start    ' skip fist 100 points
   x    = newx
   y    = newy
   IF y<0 THEN PRINT y                  ' check for off screen
   PSET(-x*scx+320,-y*scy+180),col      ' Draw
GOTO start
                                         ' Form for Matrices
trn1:
newx=0                                   ' 0.00    0.00
newy=y*.16                               ' 0.00    0.16
GOTO part2                               ' 0.00    0.00
 
trn2:
newx=.85*x + .04*y                       ' 0.85   -0.04
newy=-(.04)*x + .85*y + 1.6              ' 0.04    0.85
GOTO part2                               ' 0.00    1.60
 
trn3:
newx=.2*x - .26*y                        ' 0.20    0.23
newy=.23*x + .22*y + 1.6                 '-0.26    0.22
GOTO part2                               ' 0.00    1.60
 
trn4:
newx=(-.15*x) + .28*y                    '-0.15    0.26
newy=.26*x + .24*y + .44                 ' 0.28    0.24
GOTO part2                               ' 0.00    0.44
 
 
 
 
thesaver:                                ' Really don't get most of this...
                                         ' This is taken from the SAVEILBM prog
DIM bPlane&(5), cTabSave%(32)            ' on extras disk.  Needs extras disk
                                         ' in drive.
REM - Functions from dos.library
DECLARE FUNCTION xOpen&  LIBRARY
DECLARE FUNCTION xRead&  LIBRARY
DECLARE FUNCTION xWrite& LIBRARY
REM - xClose returns no value
 
REM - Functions from exec.library
DECLARE FUNCTION AllocMem&() LIBRARY
REM - FreeMem returns no value
 
 
LIBRARY "dos.library"
LIBRARY "exec.library"
LIBRARY "graphics.library"
 
ILBMname$="df0:Fern.out"                   ' Set name of save file
 
REM
w = 640: h = 200: d = 4                    ' Values for custom screen
 
AvailRam& = FRE(-1)
NeededRam& = ((w/8)*h*(d+1))+5000
IF AvailRam& < NeededRam& THEN
 
   GOTO Mcleanup2
END IF
 
'   SCREEN 2,w,h,d,1                        ' Did this earlier
'   t$=" SaveILBM"
'   WINDOW 2,t$,,7,2
 
REM - Get Screen structure addresses
GOSUB GetScrAddrs
 
REM - Init color cycling variables
REM - (Init to 0 for no cycling)
REM - These variables must be initialized
REM - because this version of SaveILBM
REM - always saves a Graphicraft CCRT chunk
ccrtDir%   = 1
ccrtStart% = 1
ccrtEnd%   = nColors% - 1
ccrtSecs&  = 0
ccrtMics&  = 2000
 
 
cReg = ccrtStart%
 
REM - Demo color cycling
REM - Save colors
FOR kk = 0 TO nColors% -1
   cTabSave%(kk) = PEEKW(colorTab&+(kk*2))
NEXT
 
REM - Cycle colors
deSecs& = ccrtSecs& * 3000
deMics& = ccrtMics& / 500
cStart& = colorTab& + (2*ccrtStart%)
cEnd&   = colorTab& + (2*ccrtEnd%)
repeat  = 80
 
REM - Restore colors
CALL LoadRGB4&(sViewPort&,VARPTR(cTabSave%(0)),nColors%)
 
 
REM - Save screen as ILBM file
IF (ILBMname$<>"") THEN
   saveError$ = ""
   GOSUB SaveILBM
END IF
 
Mcleanup:
'FOR de = 1 TO 5000:NEXT             ' Can keep this in if you want to get
'WINDOW CLOSE 2                      ' rid of screen once saved.
'SCREEN CLOSE 2
 
Mcleanup2:
LIBRARY CLOSE
'IF saveError$ <> "" THEN PRINT saveError$
END
 
 
 
 
SaveILBM:
REM - Saves current window's screen
REM -  as an IFF ILBM file with a
REM -  Graphicraft CCRT cycling chunk.
REM - Requires the following variables
REM -  to have been initialized:
REM -    ILBMname$ (ILBM filespec)
REM - Also, cycling variables
REM -    ccrtDir% (1,-1, or 0 = none)
REM -    ccrtStart% (low cycle reg)
REM -    ccrtEnd%   (high cycle reg)
REM -    ccrtSecs&  (cycle time in seconds)
REM -    ccrtMics&  (cycle time in microseconds)
REM
 
 
REM - init variables
f$ = ILBMname$
fHandle& = 0
mybuf& = 0
 
filename$ = f$ + CHR$(0)
fHandle& = xOpen&(SADD(filename$),1006)
IF fHandle& = 0 THEN
   saveError$ = "Can't open output file"
   GOTO Scleanup
END IF
 
REM - Alloc ram for work buffers
ClearPublic& = 65537&
mybufsize& = 120
mybuf& = AllocMem&(mybufsize&,ClearPublic&)
IF mybuf& = 0 THEN
   saveError$ = "Can't alloc buffer"
   GOTO Scleanup
END IF
 
cbuf& = mybuf&
 
REM - Get addresses of screen structures
GOSUB GetScrAddrs
 
zero& = 0
pad%  = 0
aspect% = &HA0B
 
REM - Compute chunk sizes
BMHDsize& = 20
CMAPsize& = (2^scrDepth%) * 3
CAMGsize& = 4
CCRTsize& = 14
BODYsize& = (scrWidth%/8) * scrHeight% * scrDepth%
REM - FORMsize& = Chunk sizes + 8 bytes per Chunk header + "ILBM"
FORMsize& = BMHDsize&+CMAPsize&+CAMGsize&+CCRTsize&+BODYsize&+44
 
REM - Write FORM header
tt$ = "FORM"
wLen& = xWrite&(fHandle&,SADD(tt$),4)
wLen& = xWrite&(fHandle&,VARPTR(FORMsize&),4)
tt$ = "ILBM"
wLen& = xWrite&(fHandle&,SADD(tt$),4)
 
IF wLen& <= 0 THEN
   saveError$ = "Error writing FORM header"
   GOTO Scleanup
END IF
 
REM - Write out BMHD chunk
tt$ = "BMHD"
wLen& = xWrite&(fHandle&,SADD(tt$),4)
wLen& = xWrite&(fHandle&,VARPTR(BMHDsize&),4)
wLen& = xWrite&(fHandle&,VARPTR(scrWidth%),2)
wLen& = xWrite&(fHandle&,VARPTR(scrHeight%),2)
wLen& = xWrite&(fHandle&,VARPTR(zero&),4)
temp% = (256 * scrDepth%)
wLen& = xWrite&(fHandle&,VARPTR(temp%),2)
wLen& = xWrite&(fHandle&,VARPTR(zero&),4)
wLen& = xWrite&(fHandle&,VARPTR(aspect%),2)
wLen& = xWrite&(fHandle&,VARPTR(scrWidth%),2)
wLen& = xWrite&(fHandle&,VARPTR(scrHeight%),2)
 
IF wLen& <= 0 THEN
   saveError$ = "Error writing BMHD"
   GOTO Scleanup
END IF
 
REM - Write CMAP chunk
tt$ = "CMAP"
wLen& = xWrite&(fHandle&,SADD(tt$),4)
wLen& = xWrite&(fHandle&,VARPTR(CMAPsize&),4)
 
REM - Build IFF ColorMap
FOR kk = 0 TO nColors% - 1
   regTemp% = PEEKW(colorTab& + (2*kk))
   POKE(cbuf&+(kk*3)),(regTemp% AND &HF00) / 16
   POKE(cbuf&+(kk*3)+1),(regTemp% AND &HF0)
   POKE(cbuf&+(kk*3)+2),(regTemp% AND &HF) * 16
NEXT
 
wLen& = xWrite&(fHandle&,cbuf&,CMAPsize&)
 
IF wLen& <= 0 THEN
   saveError$ = "Error writing CMAP"
   GOTO Scleanup
END IF
 
REM - Write CAMG chunk
tt$ = "CAMG"
wLen& = xWrite&(fHandle&,SADD(tt$),4)
wLen& = xWrite&(fHandle&,VARPTR(CAMGsize&),4)
vpModes& = PEEKW(sViewPort& + 32)
wLen& = xWrite&(fHandle&,VARPTR(vpModes&),4)
 
IF wLen& <= 0 THEN
   saveError$ = "Error writing CAMG"
   GOTO Scleanup
END IF
 
 
REM - Write CCRT chunk
tt$ = "CCRT"
wLen& = xWrite&(fHandle&,SADD(tt$),4)
wLen& = xWrite&(fHandle&,VARPTR(CCRTsize&),4)
wLen& = xWrite&(fHandle&,VARPTR(ccrtDir%),2)
temp% = (256*ccrtStart%) + ccrtEnd%
wLen& = xWrite&(fHandle&,VARPTR(temp%),2)
wLen& = xWrite&(fHandle&,VARPTR(ccrtSecs&),4)
wLen& = xWrite&(fHandle&,VARPTR(ccrtMics&),4)
wLen& = xWrite&(fHandle&,VARPTR(pad%),2)
 
IF wLen& <= 0 THEN
   saveError$ = "Error writing CCRT"
   GOTO Scleanup
END IF
 
 
REM - Write BODY chunk
tt$ = "BODY"
wLen& = xWrite&(fHandle&,SADD(tt$),4)
wLen& = xWrite&(fHandle&,VARPTR(BODYsize&),4)
 
scrRowBytes% = scrWidth% / 8
FOR rr = 0 TO scrHeight% -1
   FOR pp = 0 TO scrDepth% -1
      scrRow& = bPlane&(pp)+(rr*scrRowBytes%)
      wLen& = xWrite&(fHandle&,scrRow&,scrRowBytes%)
      IF wLen& <= 0 THEN
         saveError$ = "Error writing BODY"
         GOTO Scleanup
      END IF
   NEXT
NEXT
 
 
saveError$ = ""
 
Scleanup:
IF fHandle& <> 0 THEN CALL xClose&(fHandle&)
IF mybuf& <> 0 THEN CALL FreeMem&(mybuf&,mybufsize&)
RETURN
 
 
 
GetScrAddrs:
REM - Get addresses of screen structures
   sWindow&   = WINDOW(7)
   sScreen&   = PEEKL(sWindow& + 46)
   sViewPort& = sScreen& + 44
   sRastPort& = sScreen& + 84
   sColorMap& = PEEKL(sViewPort& + 4)
   colorTab&  = PEEKL(sColorMap& + 4)
   sBitMap&   = PEEKL(sRastPort& + 4)
 
   REM - Get screen parameters
   scrWidth%  = PEEKW(sScreen& + 12)
   scrHeight% = PEEKW(sScreen& + 14)
   scrDepth%  = PEEK(sBitMap& + 5)
   nColors%   = 2^scrDepth%
 
   REM - Get addresses of Bit Planes
   FOR kk = 0 TO scrDepth% - 1
      bPlane&(kk) = PEEKL(sBitMap&+8+(kk*4))
   NEXT
RETURN