Hexagonal Quilts Program
DEFDBL I, P-Q, X-Z
DEFINT M
ON ERROR GOTO errortrap
DIM mcount(160, 160), mcolor(200), colord(16)
DEF fnxpix (x) = nstartx + (npixelx - nstartx) * x / nperiod
DEF fnypix (y) = npixely - npixely * y / nperiod
GOSUB initialize
GOSUB setcolors
GOSUB menu
iterates = 1
loops:
GOSUB iterate
x = xnew: y = ynew
GOSUB plotpoints
a$ = INKEY$
IF a$ = "c" THEN iterates = 1: CLS : GOSUB setscreen
IF a$ = "i" THEN LOCATE 1, 1: PRINT "iterates ="; iterates
restart:
IF a$ = "m" THEN GOSUB menu
iterates = iterates + 1
GOTO loops
iterate:
s11 = SIN(p2 * (el11 * x + el12 * y))
s12 = SIN(p2 * (el21 * x + el22 * y))
s13 = SIN(p2 * (el31 * x + el32 * y))
s21 = SIN(p2 * (em11 * x + em12 * y))
s22 = SIN(p2 * (em21 * x + em22 * y))
s23 = SIN(p2 * (em31 * x + em32 * y))
s31 = SIN(p2 * (en11 * x + en12 * y))
s32 = SIN(p2 * (en21 * x + en22 * y))
s33 = SIN(p2 * (en31 * x + en32 * y))
s3h1 = SIN(p2 * (enh11 * x + enh12 * y))
s3h2 = SIN(p2 * (enh21 * x + enh22 * y))
s3h3 = SIN(p2 * (enh31 * x + enh32 * y))
sx = (el11 * s11 + el21 * s12 + el31 * s13)
sy = (el12 * s11 + el22 * s12 + el32 * s13)
xnew = ma * x + lambda * sx - omega * sy
ynew = ma * y + lambda * sy + omega * sx
xnew = xnew + alpha * (em11 * s21 + em21 * s22 + em31 * s23)
ynew = ynew + alpha * (em12 * s21 + em22 * s22 + em32 * s23)
xnew = xnew + a11 * s31 + a21 * s32 + a31 * s33
ynew = ynew + a12 * s31 + a22 * s32 + a32 * s33
xnew = xnew + ah11 * s3h1 + ah21 * s3h2 + ah31 * s3h3
ynew = ynew + ah12 * s3h1 + ah22 * s3h2 + ah32 * s3h3
by = 2 * ynew / sq3: bx = xnew - by / 2
IF bx > 1 THEN bx = bx - INT(bx)
IF by > 1 THEN by = by - INT(by)
IF bx < 0 THEN bx = bx + INT(-bx) + 1
IF by < 0 THEN by = by + INT(-by) + 1
xnew = bx * k11 + by * k21: ynew = bx * k12 + by * k22
IF toggle = 0 THEN RETURN
mxnew = bx*(npixelx-nstartx)/nperiod: mynew = by*npixely/nperiod
mcount(mxnew, mynew) = mcount(mxnew, mynew) + 1
RETURN
menu:
GOSUB parameters
PRINT "No. periods = "; nperiod; ""
PRINT USING "(X,y)= ##.#### ##.####"; x; y
PRINT "T to toggle coloring:";
IF toggle = 0 THEN PRINT " coloring off" ELSE PRINT " coloring on"
PRINT "ESC to exit"
PRINT "R for RETURN"
1010 b$ = INKEY$
iterates = 1
IF b$ = "" THEN 1010
IF b$ = "l" THEN INPUT "lambda = ", lambda
IF b$ = "a" THEN INPUT "alpha =", alpha
IF b$ = "b" THEN INPUT "beta =", beta
IF b$ = "g" THEN INPUT "gamma =", gamma
IF b$ = "o" THEN INPUT "omega =", omega
IF b$ = "m" THEN INPUT "m =", ma
IF b$ = "t" THEN toggle = 1 - toggle
IF b$ = "n" THEN INPUT "# of periods =", nperiod: GOSUB setscreen
IF b$ = "x" THEN GOSUB initialpoint
IF b$ = "r" THEN CLS:iterates=1: GOSUB setscreen: GOSUB vector3: RETURN
IF b$ = CHR$(27) THEN STOP
CLS
GOTO menu
parameters:
LOCATE 1, 1
PRINT "iterates= "; iterates
PRINT "Lambda ="; lambda
PRINT "Alpha = "; alpha
PRINT "Beta = "; beta
PRINT "Gamma = "; gamma
PRINT "Omega = "; omega
PRINT "M ="; ma
LINE (nstartx, 0)-(nstartx, npixely)
RETURN
initialize:
toggle = 0: ncolor = 15
nperiod = 3
nscreen = 12
npixelx = 640: npixely = 480: nstartx = 160
CLS
SCREEN nscreen
pi = 355 / 113: p2 = 2 * pi
sq3 = SQR(3)
x = .1: y = .3: xnew = x: ynew = y
delta= .1: alpha= -.1: beta= -.076: gamma= 0: omega= 0: ma= 0
GOSUB setvectors
GOSUB vector3
RETURN
errortrap:
x = .0234: y = .12345: xnew = x: ynew = y
a$ = "m"
RESUME restart
initialpoint:
CLS
PRINT "Enter r to reset coordinates automatically"
PRINT "Enter x to INPUT coordinates"
3010 C$ = INKEY$
IF C$ <> "r" AND C$ <> "x" THEN 3010
IF C$ = "r" THEN x = .3: y = .5345
IF C$ = "x" THEN INPUT "(x,y) coordinates =", x, y
xnew = x: ynew = y
RETURN
setscreen:
GOSUB parameters
IF toggle = 0 THEN RETURN
FOR j = 0 TO (npixelx - nstartx) / nperiod
FOR i = 0 TO npixely / nperiod
mcount(j, i) = 0
NEXT i
NEXT j
FOR i = 1 TO 15
LINE (0,npixely-20*i)-(15,npixely-20*(i+1)), colord(i), BF
NEXT i
RETURN
setcolors:
colord(1) = 8: colord(2) = 6: colord(3) = 1: colord(4) = 9
colord(5) = 3: colord(6) = 11: colord(7) = 2: colord(8) = 10
colord(9) = 5: colord(10) = 13: colord(11) = 4: colord(12) = 12
colord(13) = 14: colord(14) = 7: colord(15) = 15
FOR j = 1 TO 15
mcolor(j) = colord(j)
NEXT j
RETURN
plotpoints:
FOR i = -nperiod / 2 - 1 TO nperiod / 2 + 1
FOR j = 0 TO nperiod
xx = fnxpix(x + i * k11 + j * k21)
IF xx < nstartx THEN 160
IF toggle = 0 THEN PSET (xx,fnypix(y+i*k12+j*k22)): GOTO 160
mc = mcount(mxnew, mynew)
IF mc < 15 THEN mm = mcolor(mc) ELSE mm = 15
PSET (xx, fnypix(y + i * k12 + j * k22)), mm
160 NEXT j
NEXT i
RETURN
setvectors:
k11 = 1: k12 = 0
k21 = 1 / 2: k22 = sq3 / 2
el11 = 1: el12 = -1 / sq3
el21 = 0: el22 = 2 / sq3
el31 = -(el11 + el21): el32 = -(el12 + el22)
em11 = 2 * el11 + el21: em12 = 2 * el12 + el22
em21 = 2 * el21 + el31: em22 = 2 * el22 + el32
em31 = 2 * el31 + el11: em32 = 2 * el32 + el12
en11 = 3 * el11 + 2 * el21: en12 = 3 * el12 + 2 * el22
en21 = 3 * el21 + 2 * el31: en22 = 3 * el22 + 2 * el32
en31 = 3 * el31 + 2 * el11: en32 = 3 * el32 + 2 * el12
enh11 = 3 * el11 + el21: enh12 = 3 * el12 + el22
enh21 = 3 * el21 + el31: enh22 = 3 * el22 + el32
enh31 = 3 * el31 + el11: enh32 = 3 * el32 + el12
RETURN
vector3:
a11 = beta: a12 = gamma
a21 = (-a11 - sq3 * a12) / 2: a22 = (sq3 * a11 - a12) / 2
a31 = -a11 - a21: a32 = -a12 - a22
ah11 = a11: ah12 = -a12
ah21 = (-ah11 - sq3 * ah12) / 2: ah22 = (sq3 * ah11 - ah12) / 2
ah31 = -ah11 - ah21: ah32 = -ah12 - ah22
RETURN