
; Copyright 1983 by Action Computer Services
; All Rights Reserved
; last modified July, 1984

MODULE ; KAL3.ACT

DEFINE STRING="CHAR ARRAY"

SET $E=$CB
SET $F=0

BYTE ARRAY line

SET $E=$5000
SET $491=$5000

BYTE low=line,
     high=line+1,
     x0=$D6,
     y0=$D7,
     x1=$D8,
     y1=$D9,
     t=$DA

CARD aXI,bXI,cXI,aYI,bYI,cYI, ;initial
     aX,aY,bX,bY,cX,cY,       ;plot
     xA,yA,xB,yB,xC,yC,       ;erase
     period,npts,
     cntP,cntE,ystart,ytop

BYTE ARRAY mask1(0)=[$80 $40 $20 $10 $8 $4 $2 $1],
           mask2(0)=[$7F $BF $DF $EF $F7 $FB $FD $FE],
           yLocL(129),
           yLocH(129),
           rsh3(256)

;************************************
;Set up plot and erase values.
;************************************

PROC InitP()

  aX=aXI
  bX=bXI
  cX=cXI
  aY=aYI
  bY=bYI
  cY=cYI
  cntP=period
  xA=aXI
  yA=aYI
  xB=bXI
  yB=bYI
  xC=cXI
  yC=cYI
  cntE=period
RETURN

;************************************
;Set up the special display list
;************************************

PROC InitGr8()

  BYTE low,high,i,
       memCtl=$D400,memCtlS=$22F

  CARD next=low,RAMTOP=$69,
       DLc=$D402,DLs=$230,
       MEMTOP=$2E5,K32=[32],j

  CARD ARRAY dl

  ; setup our special DL with inverted
  ; bottom.  Tricky, thanks Sheldon

  Graphics(17)
  SetColor(1,0,15)
  SetColor(2,0,0)
  memCtlS=0
  memCtl=0 ; turn off display
  ytop=(RAMTOP&$F000)-$1000
  ystart=ytop+512
  Zero(ytop,$1000) ; clear display
  DLs=ystart-$400
  MEMTOP=DLs-1
  dl=DLs
  dl^=$70
  dl==+1
  dl^=$4F ; load scan counter
  dl==+1
  dl^=ystart
  dl==+2
  FOR i=1 TO 110 STEP 2
    DO
    dl^=$F0F
    dl==+2
    OD
  dl^=$F   
  dl==+1
  next=ystart + 111*K32
  FOR i=0 TO 111
    DO
    dl^=$4F
    dl==+1
    dl^=next
    next=next - 32
    dl==+2
    OD
  dl^=$41
  dl==+1
  dl^=DLs
  DLc=DLs
  memCtlS=$21 ; turn display on
  next=ytop
  FOR i=0 TO 128
    DO
    yLocL(i)=low
    yLocH(i)=high
    next ==+ 32
    OD
  FOR j=0 TO 255
    DO
    rsh3(j)=j RSH 3
    OD
RETURN

;************************************
;Special plot
;************************************

PROC Plot8=*(BYTE x,y)

  BYTE x1=$A0, y1=$A1

  low=yLocL(y1)
  high=yLocH(y1)
  t=rsh3(x1)
  line(t) ==% mask1(x1&7)
RETURN

;************************************
;Special erase
;************************************

PROC Erase8=*(BYTE x,y)

  BYTE x1=$A0, y1=$A1

  low=yLocL(y1)
  high=yLocH(y1)
  t=rsh3(x1)
  line(t) ==& mask2(x1&7)
RETURN

;************************************
;Plot points
;************************************

PROC GenP()

  BYTE x=aX+1,
       y=aY+1,
       ATRACT=$4D

  aX=(aX+bX)!bX
  aY=(aY+bY)!bY
  cntP==-1
  IF cntP=0 THEN
    bX=(bX+cX)!cX
    bY=(bY+cY)!cY
    cntP=period
    ; turn off attact mode, we're
    ; changing the screen anyway
    ATRACT=0
  FI
  x1=x RSH 1
  y1=y RSH 1
  x0=x1 RSH 1
  y0=y1 RSH 1
  IF x0<=y0 THEN
    Plot8(127+x0+y0, 127+x1-y1)
    Plot8(127-x0-y0, 127+x1-y1)
    Plot8(127+x0-y1, 127-x1)
    Plot8(127-x0+y1, 127-x1)
    Plot8(127+x1-y0, 127-y1)
    Plot8(127-x1+y0, 127-y1)
  FI
RETURN

;************************************
;Erase points
;************************************

PROC GenE()

  BYTE x=xA+1,
       y=yA+1

  xA=(xA+xB)!xB
  yA=(yA+yB)!yB
  cntE==-1
  IF cntE=0 THEN
    xB=(xB+xC)!xC
    yB=(yB+yC)!yC
    cntE=period
  FI
  x1=x RSH 1
  y1=y RSH 1
  x0=x1 RSH 1
  y0=y1 RSH 1
  IF x0<=y0 THEN
    Erase8(127+x0+y0, 127+x1-y1)
    Erase8(127-x0-y0, 127+x1-y1)
    Erase8(127+x0-y1, 127-x1)
    Erase8(127-x0+y1, 127-x1)
    Erase8(127+x1-y0, 127-y1)
    Erase8(127-x1+y0, 127-y1)
  FI
RETURN

;************************************
;Read the parameters
;************************************

PROC GetParam(STRING param, CARD POINTER cur, initial)

  CARD resultC

  STRING numBuf(0)=$550

  PutE()
  Print(param)
  Print(" = ")
  PrintC(cur^)
  IF initial THEN
    Print(", initial = ")
    PrintCE(initial^)
  ELSE
    PutE()
  FI
  PrintE(" for current value")
  PrintE("* for initial value")
  Print("Enter new value 0-65535:  ")
  resultC=InputC()
  IF numBuf(0)#0 THEN
    IF numBuf(1)='* THEN
      IF initial THEN
        cur^=initial^
      FI
    ELSE
      cur^=resultC
    FI
  FI
  IF initial THEN
    initial^=cur^
  FI
RETURN

;************************************
;Change the parameters
;************************************

PROC Params()

  Graphics(0)
  PutE()
  GetParam("aX", @aX, @aXI)
  GetParam("bX", @bX, @bXI)
  GetParam("cX", @cX, @cXI)
  GetParam("aY", @aY, @aYI)
  GetParam("bY", @bY, @bYI)
  GetParam("cY", @cY, @cYI)
  GetParam("Period", @period, 0)
  GetParam("Persistence", @npts, 0)
RETURN

;************************************
;Main procedure
;************************************

PROC Kal3()

  BYTE init,trig=$D010,
       stick=$D300,CH=$2FC,
       c,s

  CARD i

  Close(7)
  Open(7,"K:",4)
  init=1
  ;change following for different patterns
  aXI=22175 ; 5221  ; 12767
  bXI=63751 ; 64449 ; 64471
  aYI=17791 ; 57669 ; 13183
  bYI=63791 ; 64489 ; 64511
  cXI=3
  cYI=3
  period=10000
  npts=2500
  DO
    IF init THEN
      InitGr8()
      InitP()
      i=0
      CH=$FF
      FOR i=1 TO npts
        DO
        GenP()
        IF CH#$FF THEN
          EXIT
        FI
        OD
      init=0
    FI
    WHILE CH=$FF
      DO
      GenP()
      GenE()
      s=stick & $F
      IF s=7 AND npts<65000 THEN
        npts==+1
        GenP()
      FI
      IF s=11 AND npts>2 THEN
        npts==-1
        GenE()
      FI
      WHILE trig=0
        DO
        OD
      OD
    c=GetD(7) ; get character
    IF c=' THEN  ; quit if ESC key
      EXIT
    ELSE
      Params()
      init=1
    FI
  OD
  Graphics(0)
RETURN
