General Information #
Author: Sol GuberLanguage: ACTION!
Compiler/Interpreter: ACTION!
Published: Analog #32 (07/ 85)
Color the shapes#
; COLOR THE SHAPES
;
; by Rebecca Guber and Sol Guber
MODULE
BYTE ARRAY
R(100),USED(60),PLAYER(20),B(90),
CLS=704,A(10),GAR(60),
INTER=[72 169 0 141 10 212 141 27
208 104 64],
TX=[0 252 0 4],TY=[248 0 8 0],
TEST=[246 255 10 1],
COLORS=[8 122 88 28 132 248 190
14 190],
STAR=[0 0 0 0 24 126 60 60 126 24
0 0 0 0]
CARD SC1,YP1,YP,Y1
BYTE CFLAG,COL,PLAYNUM,COUNT,DX,DY,
OLDX,OLDY,X,Y,TURN,QUIT
PROC SETUP()
CARD Z
Z=PEEKC(560)
POKE(Z+166,143)
POKEC(512,INTER)
POKE(54286,192)
POKE(87,10)
POKE(623,160)
FOR Z=0 TO 8 DO
CLS(Z)=PEEK(COLORS+Z)
OD
RETURN
PROC BLOCK(BYTE I)
BYTE J
FOR J=152 TO 157 DO
PLOT (I,J)
DRAWTO(I+5,J)
OD
RETURN
PROC NEWDIR(BYTE A,B)
DX=0
DY=0
IF LOCATE(A+1,B)>0 THEN
DX=1
ELSEIF LOCATE(A-1,B)>0 THEN
DX=-1
ELSEIF LOCATE(A,B-1)>0 THEN
DY=-1
ELSE
DY=1
FI
RETURN
BYTE FUNC LINE(BYTE A,B)
BYTE Z,J
Z=LOCATE(A+1,B)
J=LOCATE(A-1,B)
Z==+J
J=LOCATE(A,B+1)
Z==+J
J=LOCATE(A,B-1)
Z==+J
IF Z>6 THEN
RETURN(Z)
FI
NEWDIR(A,B)
RETURN(1)
PROC REMOVE(BYTE A,B)
DO
PLOT(A,B)
A==+DX
B==+DY
UNTIL LINE(A,B)<>1
OD
RETURN
PROC GRID()
BYTE I,X,Y,Z,XOLD,YOLD,Y1
COLOR=6
I=2
WHILE I<157 DO
PLOT(3,I)
DRAWTO(74,I)
I==+16
OD
I=3
WHILE I<79 DO
PLOT(I,2)
DRAWTO(I,145)
I==+8
OD
FOR I=2 TO 5 DO
COLOR=I
BLOCK((I-2)*10+5)
OD
COLOR=6
PLOT(45,153)
DRAWTO(50,153)
DRAWTO(50,157)
DRAWTO(45,157)
DRAWTO(45,153)
PLOT(51,158)
COLOR=0
FOR I=1 TO 40 DO
DO
X=RAND(8)*8+7
Y=RAND(16)*8+10
Y1=Y-10
IF Y1/8=(Y1/16)*2 THEN
X==+4
FI
UNTIL LOCATE(X,Y)<>0
OD
XOLD=X
YOLD=Y
IF Y1/8=(Y1/16)*2 THEN
DX=0
DY=-1
REMOVE(X,Y)
DX=0
DY=1
REMOVE(XOLD,YOLD)
ELSE
DY=0
DX=-1
REMOVE(X,Y)
DY=0
DX=1
REMOVE(XOLD,YOLD)
FI
OD
RETURN
PROC TITLE()
BYTE X,Y,C,K1,K2
CARD SC,J
SC1=PEEKC(88)
GRAPHICS(19)
SC=PEEKC(560)
FOR J=7 TO 9 DO
POKE(SC+J,7)
OD
POKE(87,2)
COLOR=0
PLOT(0,1)
PRINTDE(6,"COLOR THE SHAPES")
PRINTDE(6," by rebecca guber")
PRINTDE(6," AND SOL GUBER")
POKE(87,3)
FOR J=1 TO 1000 DO
FOR K2=1 TO 500 DO
OD
X=RAND(39)
Y=RAND(12)+8
C=RAND(255)
SOUND(0,C,8,8)
COLOR=RAND(4)
PLOT(X,Y)
OD
SOUND(0,0,0,0)
RETURN
BYTE FUNC NEWSPOT(BYTE J,COUNT)
BYTE K,Y1,X1,Z,K1
R(J)==+128
Y1=((J-1)/10)*16+10
X1=((J-1) MOD 10)*8+7
FOR K=0 TO 3 DO
Z=LOCATE(X1+TX(K),Y1+TY(K))
K1=J+TEST(K)
IF Z=0 AND R(K1)=0 THEN
R(K1)=COUNT
RETURN(K1)
FI
OD
RETURN(0)
BYTE FUNC OLDSPOT(BYTE J,COUNT)
BYTE K,K1
R(J)==-128
K=3
WHILE K<>255 DO
K1=J+TEST(K)
IF K1>0 AND K1<100 THEN
IF R(K1)>128 THEN
R(K1)==-128
RETURN(K1)
FI
FI
K==-1
OD
RETURN(0)
PROC FIND(BYTE J,COUNT)
BYTE K,K1
R(J)=COUNT
DO
K=NEWSPOT(J,COUNT)
IF K=0 THEN
K1=OLDSPOT(J,COUNT)
J=K1
ELSE
J=K
FI
UNTIL J=0
OD
RETURN
PROC SEARCH()
BYTE J,COUNT,K,K1
ZERO(R,100)
COUNT=1
FOR J=1 TO 89 DO
IF R(J)=0 AND J MOD 10<>0 THEN
FIND(J,COUNT)
COUNT==+1
FI
OD
FOR J=1 TO 89 DO
IF R(J)>128 THEN
R(J)==-128
FI
OD
RETURN
; PMG.ACT FROM THE ACTION! TOOLKIT
INCLUDE "D1:PMG.ACT"
BYTE FUNC SIZE(BYTE K)
BYTE J
FOR J=K+1 TO K+9 DO
IF R(J)=COUNT THEN
RETURN(1)
FI
OD
RETURN(0)
PROC CHECK_BOARD()
BYTE J,K
COUNT=1
FOR J=1 TO 99 DO
IF J MOD 10 <>0 THEN
WHILE R(J)<COUNT AND J<100 DO
J==+1
OD
GAR(COUNT)=J/10
K=(J/10)*10+10
WHILE SIZE(K)=1 DO
K==+10
OD
GAR(COUNT)==+(K-10)
COUNT==+1
FI
OD
COUNT==-1
RETURN
PROC SHIFT(BYTE X1)
BYTE Z,Z1
IF X1=140 THEN
QUIT=1
RETURN
FI
Z=(X1-60)/20+1
COL=Z+1
Z1=PEEK(705+Z)-6
POKE(705,Z1)
RETURN
PROC BEEP()
CARD Q
SOUND(0,220,10,10)
FOR Q=1 TO 25000 DO
OD
SOUND(0,0,0,0)
RETURN
BYTE FUNC PICK_COLOR()
BYTE S,TR,J,X1
CARD I1
FOR I1=OLDY TO 173 DO
PMMOVE(1,X,I1)
OD
OLDY=173
PRINTE("PLEASE PICK A COLOR")
X1=60
PMHPOS(1)=60
IF CFLAG=1 THEN
DO
J=PEEK(624)
IF J>5 THEN
J=(J/50)*20+60
PMHPOS(1)=J
FI
IF PEEK(636)=0 OR
PEEK(637)=0 THEN
BEEP()
SHIFT(J)
RETURN(1)
FI
OD
FI
DO
DO
S=STICK(0)
TR=STRIG(0)
IF TR=0 THEN
BEEP()
SHIFT(X1)
RETURN(1)
FI
UNTIL S<>15
OD
IF S=7 THEN
X1==+20
IF X1=160 THEN
X1=60
FI
FI
IF S=11 THEN
X1==-20
IF X1=40 THEN
X1=140
FI
FI
PMHPOS(1)=X1
FOR I1=1 TO 6000 DO
OD
OD
RETURN(1)
BYTE FUNC GOOD_COLOR(BYTE SPOT,COL)
BYTE TOP,BOT,BLOCK,I
BLOCK=R(SPOT)
TOP=GAR(BLOCK)
BOT=(TOP MOD 10)*10
TOP=(TOP/10)*10
WHILE BOT<TOP+9 DO
IF R(BOT)=BLOCK THEN
FOR I=0 TO 3 DO
IF B(BOT+TEST(I))=COL THEN
RETURN(0)
FI
OD
FI
BOT==+1
OD
RETURN(1)
PROC FILLER(BYTE J)
BYTE X,Y,K,L,L1
L1=6
IF R(J)=R(J+1) THEN
L1==+1
FI
L=14
IF R(J)=R(J+10) THEN
L==+1
FI
X=(J/10)*16+3
Y=(J MOD 10)*8-4
FOR K=X TO X+L DO
PLOT(Y,K)
DRAWTO(Y+L1,K)
OD
RETURN
PROC FILL_IN(BYTE SPOT)
BYTE N,TOP,BOT,J
N=R(SPOT)
TOP=GAR(N)
BOT=TOP MOD 10
TOP=(TOP/10)*10
USED(N)=1
FOR J=BOT TO TOP+9 DO
IF R(J)=N THEN
B(J)=COLOR
FILLER(J)
FI
OD
RETURN
PROC INIT()
BYTE K,J,M,N,C
ZERO(PLAYER,20)
ZERO(B,99)
ZERO(USED,60)
PUT(125)
PRINTE("1 OR 2 PLAYERS?")
PLAYNUM=INPUTB()
PRINTE("WHAT IS YOUR NAME?")
INPUTS(A)
FOR K=1 TO A(0) DO
PLAYER(K)=A(K)
OD
IF PLAYNUM=2 THEN
PRINTE("NAME OF 2ND PLAYER?")
INPUTS(A)
FOR K=1 TO A(0) DO
PLAYER(K+10)=A(K)
OD
FI
PUT(125)
PRINT("USE A KOALA PAD (Y/N)?")
CFLAG=0
INPUTS(A)
IF A(1)='Y THEN
CFLAG=1
FI
PRINTE("FILL SOME SHAPES IN?")
INPUTS(A)
IF A(1)<>'Y THEN
RETURN
FI
PUT(125)
PRINTE("HOW MANY SHAPES, UP TO 5?")
J=INPUTB()
J==MOD 6
FOR K=1 TO J DO
DO
M=RAND(COUNT-1)+1
UNTIL USED(M)=0
OD
N=M
DO
N==+1
UNTIL R(N)=M
OD
DO
C=RAND(4)+2
UNTIL GOOD_COLOR(N,C)=1
OD
COLOR=C
FILL_IN(N)
USED(M)=1
OD
RETURN
BYTE FUNC SGN(BYTE I,J)
IF I=J THEN
RETURN(0)
ELSEIF I>J THEN
RETURN(-1)
FI
RETURN(1)
PROC MOVE()
BYTE Q,DEL
CARD K
IF OLDX<>X THEN
Q=OLDX
DEL=SGN(OLDX,X)
WHILE Q<>X DO
PMMOVE(1,Q,OLDY)
Q==+DEL
OD
OLDX=X
FOR K=1 TO 2000 DO
OD
FI
IF OLDY<>Y THEN
Q=OLDY
DEL=SGN(OLDY,Y)
WHILE Q<>Y DO
PMMOVE(1,X,Q)
Q==+DEL
OD
OLDY=Y
FI
RETURN
BYTE FUNC TRIGGER()
IF CFLAG=1 THEN
IF PEEK(636)=0 OR PEEK(637)=0 THEN
RETURN(0)
FI
ELSE
IF STRIG(0)=0 THEN
RETURN(0)
FI
FI
RETURN(1)
BYTE FUNC ABS(BYTE A,B)
IF A>B THEN
RETURN(A-B)
FI
RETURN(B-A)
BYTE FUNC JOYSTICK()
BYTE P,X1
IF CFLAG=1 THEN
X1=PEEK(624)
Y1=PEEK(625)
IF X1<5 OR Y1<5 THEN
RETURN(0)
FI
X1=56+(X1/28)*16
Y1=36+(Y1/28)*16
IF ABS(X1,OLDX)<5 THEN
RETURN(0)
ELSEIF ABS(Y1,OLDY)<5 THEN
RETURN(0)
FI
X=X1
Y=Y1
RETURN(1)
FI
P=STICK(0)
IF P=15 THEN
RETURN(0)
FI
IF P=11 AND OLDX>60 THEN
X=OLDX-16
RETURN(1)
ELSEIF P=7 AND OLDX<180 THEN
X=OLDX+16
RETURN(1)
ELSEIF P=14 AND OLDY>51 THEN
Y=OLDY-16
RETURN(1)
ELSEIF P=13 AND OLDY<152 THEN
Y=OLDY+16
RETURN(1)
FI
RETURN(0)
BYTE FUNC COMPLETE()
BYTE J
FOR J=1 TO COUNT-1 DO
IF USED(J)=0 THEN
RETURN(0)
FI
OD
RETURN(1)
PROC NAME()
BYTE J
PUT(125)
FOR J=TURN*10+1 TO TURN*10+10 DO
PUT(PLAYER(J))
IF PLAYER(J+1)=0 THEN
EXIT
FI
OD
PRINTE("'S TURN")
RETURN
PROC COLOR_IN(BYTE SPOT)
BYTE K
CARD K1
IF B(SPOT)<>0 THEN
DO
UNTIL PICK_COLOR()<>0
OD
MOVE()
IF QUIT=1 THEN
RETURN
FI
X=OLDX
Y=OLDY
MOVE()
RETURN
FI
IF GOOD_COLOR(SPOT,COL)=0 THEN
BEEP()
PRINT("YOU CANNOT USE THAT")
PRINTE(" COLOR THERE")
BEEP()
RETURN
FI
COLOR=COL
FILL_IN(SPOT)
IF PLAYNUM=2 THEN
TURN==! 1
FI
NAME()
FOR K1=1 TO 2000 DO
OD
RETURN
PROC SHAPES()
BYTE A,SPOT,J
DO
TITLE()
GRAPHICS(8)
QUIT=0
PMGRAPHICS(1)
SETUP()
POKE(705,22)
POKE(623,160)
PMCLEAR(1)
MAKEPM(STAR,14,1,2,156,126)
X=56
Y=36
OLDX=0
OLDY=0
MOVE()
COLOR=3
COL=3
GRID()
TURN=0
SEARCH()
CHECK_BOARD()
INIT()
NAME()
DO
IF TRIGGER()=0 THEN
COLOR_IN(SPOT)
FI
IF JOYSTICK()=1 THEN
MOVE()
FI
SPOT=(X-38)/16+10*(Y-36)/16
UNTIL COMPLETE()=1 OR QUIT=1
OD
IF COMPLETE()=1 THEN
FOR J=TURN*10+1 TO TURN*10+10 DO
PUT(PLAYER(J))
IF PLAYER(J+1)=0 THEN
EXIT
FI
OD
PRINTE(" IS THE WINNER")
FI
PRINTE("PLAY AGAIN?")
A=INPUTB()
UNTIL A='N
OD
RETURN
