--------------------
to main ; Carpet
3d_frame
sphc -81 -81 0 7
draw 163 4
end
to draw :side :level
if :level<1[stop]
repeat 4[shape rt 90]
fill_it
end
to shape
draw :side/3 :level-1
fd :side/3
draw :side/3 :level-1
fd 2*:side/3
end
to fill_it
pu rt 45 fd .7*:side
setfc 5-:level fill
bk .7*:side lt 45 pd
end
to procs
ed[main draw shape fill_it procs]
end
--------------------
to main ; Cones
3d_frame
setpc 6 pu
for[rad 32 4 -2][draw :rad]
end
to draw :rad
for[i 1 6][
seth :i*60 fd 2*:rad rt 45
pd arc 270 :rad pu home]
setfc(se 8*:rad-1 0 0) fill
end
to procs
ed[main draw procs]
end
--------------------
to main ; Arabesq
3d_frame
sphc -77 -77 0 4 setpensize[5 5] draw 22
sphc -77 -77 0 7 setpensize[3 3] draw 22
sphc -77 -77 0 6 setpensize[1 1] draw 22
end
to draw :s
outer
link
inner
end
to outer
u 3*:s r 2*:s jump r 4*:s d 3*:s
l 3*:s u 2*:s jump u 4*:s r 3*:s
d 3*:s l 2*:s jump l 4*:s u 3*:s
r 3*:s d 2*:s jump d 4*:s l 3*:s
end
to link
pu u :s r :s pd
end
to inner
u :s r :s jump r 3*:s d :s
l :s u :s jump u 3*:s r :s
d :s l :s jump l 3*:s u :s
r :s d :s jump d 3*:s l :s
end
to jump
pu fd :s pd
end
to u :size
seth 0 fd :size
end
to d :size
seth 180 fd :size
end
to l :size
seth 270 fd :size
end
to r :size
seth 90 fd :size
end
to procs
ed[main draw outer link inner jump u d r l procs]
end
--------------------
to main ; Bugs
3d_frame
pu init 10
end
to init :num
make "bugs(array :num 0)
for[i 0 :num-1][
fd 95 setitem :i :bugs pos
bk 95 rt 360/:num]
poly
move 0
end
to poly
setpc 1 setpensize[2 2]
for[current 0 :num-1][
pu setpos item :current :bugs
pd setpos item next :bugs]
setpc 6 setpensize[1 1]
end
to move :current
go item :current :bugs item next :bugs
fd 1
if equalp :num 1+:current[
if lessp distance[0 0] 1.5[stop]]
setitem :current :bugs pos
move next
end
to go :pos :head
pu setpos :pos
seth towards :head pd
end
to next
op remainder 1+:current :num
end
to procs
ed[main init poly move go next procs]
end
--------------------
to main ; Sin_Cos by Olga
3d_frame
setpc 4
patterns 3 4 2
end
to patterns :a :b :s
form.arrays
draw 8
end
to form.arrays
; forms arrays of x-y coordinates
; according the to trig formulas
make "xarr(array 361 0)
make "yarr(array 361 0)
for[i 0 360][
setitem :i :xarr 90*(sin 5*:i)*(cos :a*:i)
setitem :i :yarr 90*(cos 5*:i)*(sin :b*:i)]
end
to draw :k
; each i-th point is joined with
; point number i+k, thus
; different parterns are formed
for[i 0 360-:k][
setxy item :i :xarr item :i :yarr
setxy item :i+:k :xarr item :i+:k :yarr]
end
to procs
ed [main patterns form.arrays draw procs]
end
--------------------
to main ; Cardio
3d_frame
setpc 6 draw 35
end
to draw :rad
sph 0 23 90 pu
repeat 24[fd :rad pd
circle distance se 0 23+:rad
pu bk :rad rt 360/24]
end
to procs
ed[main draw procs]
end
--------------------
to main ; Cubes
3d_frame
sphc -77 -44 0 6 draw 15
end
to draw :size
repeat 2[lup] lt 60 fd 6*:size rt 60 fd 3*:size lup
rup fd 3*:size lt 120 fd 3*:size rt 60 fd 3*:size rt 120
rup fd 3*:size lt 120 fd 3*:size rt 120 rup rup lup
lt 120 fd 3*:size rt 60 lup rt 60 lup
bk 3*:size lt 60 rup fd 3*:size lt 120 rup
end
to lup
repeat 3[3lup pu bk 3*:size rt 120 fd :size lt 120 pd]
end
to 3lup ; 3 lines up
repeat 3[1lup pu fd :size pd]
end
to 1lup
repeat 2[fd :size rt 120 fd :size rt 60]
end
to rup ; row up
repeat 3[3rup pu bk 3*:size rt 60 fd :size lt 60 pd]
end
to 3rup ; 3 rows up
repeat 3[1rup pu fd :size pd]
end
to 1rup
repeat 2[fd :size rt 60 fd :size rt 120]
end
to procs
ed[main draw lup 3lup 1lup rup 3rup 1rup procs]
end
--------------------
to main ; Cubic by Olga
3d_frame
setpensize[3 3] sphc -26 -23 0 4 draw 32
setpensize[1 1] sphc -26 -23 0 6 draw 32
end
to draw :a
hexa6 :a fd :a rt 60 fd :a lt 60
hexa6 :a lt 60 bk :a rt 60 bk :a
hexa6 :a
end
to hexa6 :a
repeat 6[hexa :a rt 60]
end
to hexa :a
repeat 6[fd :a rt 60]
end
to procs
ed[main draw hexa6 hexa procs]
end
--------------------
to main ; Yinyang
3d_frame
draw 80
end
to draw :rad
setpc 6 circle :rad
sph 0 :rad 90
arcr 180 :rad/2
arcl 180 :rad/2
setfc 1 sp 0 .75*:rad fill
setfc 7 sp 0 -.75*:rad fill
eyes
end
to eyes
setfc 1 sp 0 -:rad/2 circle :rad/10 fill
setfc 7 sp 0 :rad/2 circle :rad/10 fill
end
to procs
ed[main draw eyes procs]
end
--------------------
to main ; Sun
3d_frame
sphc 56 -80 0 7
repeat 9[draw 34 rt 160]
fill_it
end
to draw :rad
repeat 2[arcl 90 :rad arcr 90 :rad]
end
to fill_it
pu home
setfc 6 repeat 9[fd 40 fill bk 40 rt 360/9]
setfc 1 repeat 9[fd 20 fill bk 20 rt 360/9]
rt 15
setfc 3 repeat 9[fd 16 fill bk 16 rt 360/9]
setfc 4 fill
end
to procs
ed[main draw fill_it procs]
end
--------------------
to main ; Escher
3d_frame
draw 45
fill_it
end
to draw :size
setpc 6
pu setxy .75*:size -.75*:size pd
repeat 3[part :size fd 1.5*:size lt 120]
end
to part :size
fd 2*:size lt 120 fd 3*:size rt 120
fd :size/2 rt 60 fd 3.5*:size rt 120
fd 3*:size rt 120 fd :size/2 rt 60
end
to fill_it
sph 10 0 0 pu
repeat 3[fd 51
setfc(se 63+repcount*64 0 0) fill bk 45 rt 120]
end
to procs
ed[main draw part fill_it procs]
end
--------------------
to main ; Darts
3d_frame
setpc 7 draw
setfc 4 pu fill_it
end
to draw
for[rad 90 30 -30][circle :rad setfc 14 fill]
setpc 0 repeat 12[fd 90 bk 90 rt 30] ; rays
end
to fill_it
repeat 6[seth 15+repcount*60 fd 45 fill home]
repeat 6[seth 45+repcount*60 fd 15 fill fd 60 fill home]
end
to procs
ed[main draw fill_it procs]
end
--------------------
to main ; Turtle
3d_frame
do 70
end
to do :size
legs
pu fd :size/2 pd
repeat 5[top]
eyes
end
to legs
sph -.81*:size -.3*:size 18
repeat 5[pu fd :size/3 lt 108 penta :size/3
rt 108 pu fd 2*:size/3 rt 72]
end
to top
fd :size/2 rt 72 fd :size/2 rt 90
fd .3718*:size rt 54
fd .3718*:size rt 54
fd .3718*:size rt 90
fd :size/2 rt 72 fd :size/2
end
to eyes
pu fd .85*:size rt 72 fd :size/4
penta :size/16 eyefill
fd :size/5
penta :size/16 eyefill
fill_it
end
to eyefill
setfc 4
pu rt 36 fd 3 fill
bk 3 lt 36
end
to penta :size
setpc 2 pd
repeat 5[fd :size rt 72]
end
to fill_it
setfc 10
pu home fill
seth 36
repeat 5[fd :size/2 fill bk :size/2 rt 72]
seth 0
repeat 5[fd :size fill bk :size rt 72]
end
to procs
ed[main do legs top eyes eyefill penta fill_it procs]
end
--------------------
to main ; Gasket
3d_frame
pu select rndvertex 0
end
to select :pnt :count
setxy x y
if 5<:count[setpixel 4]
select rndvertex 1+:count
end
to rndvertex
op pick[
[-162 162][0 162][162 162]
[-162 0] [162 0]
[-162 -162][0 -162][162 -162]]
end
to x
op(xcor+item 1 :pnt)/3
end
to y
op(ycor+item 2 :pnt)/3
end
to procs
ed[main select rndvertex x y procs]
end
--------------------
to main ; Corset
3d_frame
setscrunch 1 .4
sphc -58 150 0 3
pu repeat 36[fd 6 rt 6] pd
draw pos heading [-58 -150] 0 0
end
to draw :pos1 :head1 :pos2 :head2 :counter
if :counter>120[stop]
setpos :pos1 seth :head1
fd 6 rt 6
draw :pos2 :head2 pos heading 1+:counter
end
to procs
ed[main draw procs]
end
--------------------
to main ; Mgndvd2 by Olga
3d_frame
setpc 3 setpensize[2 2]
draw 155 100
end
to draw :a :b
repeat 6[rt_strip repcount lt_strip repcount]
end
to rt_strip :u
pu home seth(:u-1)*60 bk :a/sqrt 3 rt 30 pd
fd :a/3
pu fd h pd
fd :a/3 fd :a/3-h
pu home seth(:u-1)*60 bk :b/sqrt 3 rt 30 pd
fd :b/3-h
pu fd h pd
fd 2*:b/3
end
to lt_strip :u
pu home seth(:u-1)*60 bk :a/sqrt 3 lt 30 pd
fd :a/3 fd :a/3-h
pu fd h pd
fd :a/3
pu home seth(:u-1)*60 bk :b/sqrt 3 lt 30 pd
fd 2*:b/3
pu fd h pd
fd :b/3-h
end
to h
op (:a-:b)/2
end
to procs
ed[main draw rt_strip lt_strip h procs]
end
--------------------
to main ; Lissajous
3d_frame
setpc 6 lissa 80 18 19
end
to lissa :mult :a :b
for[x 0 360][
setxy :mult*sin :a*:x :mult*sin :b*:x]
end
to procs
ed[main lissa procs]
end
--------------------
to main ; Jellyfish by Olga
3d_frame
do 90 2 4 3 0
end
to do :r :k :a :b :t
if :t>360[stop]
setpc(se random 256 random 256 random 256)
sp 0 80 setxy x y
setpensize[4 4] setpc 4 fd 0
setpensize[1 1]
do :r :k :a :b :t+2*pi/10
end
to x
op :r*(sin :k*:t)*(cos :a*:t)
end
to y
op :r*(cos :k*:t)*(sin :b*:t)
end
to procs
ed[main do x y procs]
end
--------------------------------
to main ; Menorah by Olga
3d_frame
sphc 0 -20 0 7 draw 51
end
to draw :size
stand
waves
candles
end
to stand
pu rt 90 bk :size pd
repeat 2[arcr 180 :size/2 bk 2*:size]
rt 45 pu fd :size setfc 11 fill
bk :size lt 45
end
to waves
setpc 3
rt 90 pu bk 2*:size/9 pd
repeat 9[arcl 180 :size/9 rt 180]
end
to candles
rt 270 pu bk :size/9 lt 90
setpc 6 repeat 8[stick]
pd fd :size+:size/3
pu fd :size/9
flame ; Shamash
rt 90 pu bk :size/3 lt 90
repeat 8[pu bk 2*:size/9 flame]
end
to stick
pd fd :size
rt 90 pu bk 2*:size/9 lt 90
bk :size
end
to flame
pd setpc 6 seth 0
arcr 90 :size/5
arcl 90 :size/5 rt 180
arcr 90 :size/2.5
setfc 4
lt 30 pu bk :size/9 fill
fd :size/9 rt 30
end
to procs
ed[main draw stand waves
candles stick flame procs]
end
--------------------
to main ; Glass, Initial idea by Andrzej Baczynski
3d_frame
setscrunch 1 .4
setpensize[1 1] base
setpensize[2 2] cup
setscrunch 1 1
end
to base
sp -40 -200 ;center it
repeat 60[fd 4 rt 6 line []]
setpc 7 ; white
repeat 60[fd 4 rt 6]; rim
end
to cup
sp -59 150 ;center it
repeat 30[fd 6 rt 6 line []]
setpc 7 ; white
repeat 60[fd 6 rt 6]; rim
end
to line :ll
push "ll pos push "ll heading
setpc 1+random 15
setxy 0 -195
seth pop "ll setpos pop "ll
end
to procs
ed[main base cup line procs]
end
--------------------
to main ; Nephro
3d_frame
setpc 4 draw 46
end
to draw :size
pu
repeat 32[
fd :size pd circle xcor
pu bk :size rt 360/32]
end
to procs
ed[main draw procs]
end
--------------------
to main ; Packman
3d_frame
sphc 10 0 135 7 draw
fill_it
end
to draw
arc 270 70 ; head
seth -45 fd 70 bk 70 lt 90 fd 71; mouth
for[x -25 -75 -25][sp :x 0 circle 10]
sp 5 40 circle 10 ; eye
end
to fill_it
sp 50 0 setfc 4 fill ; head
setfc 6
for[x -25 -75 -25][sp :x 0 fill]
sp 5 40 fill ; eye
end
to procs
ed[main draw fill_it procs]
end
--------------------
to main ; Chaos
3d_frame
sp 0 -25 pu
set_attractors 111
end
to set_attractors :size
for[pnt 1 3][
fd :size make :pnt pos
bk :size rt 120]
setpos :1
select 1+random 3
end
to select :pnt
setxy midx midy
setpixel :pnt
select 1+random 3
end
to midx
op(xcor+first thing :pnt)/2
end
to midy
op(ycor+ last thing :pnt)/2
end
to procs
ed[main set_attractors select midx midy procs]
end
--------------------
to main ; Flower by Olga
3d_frame
setpc 7 flower 32
end
to flower :size
for[i 1 6][leaf fill_it rt 150]
end
to leaf
setpc 7
arcr 90 :size arcl 90 :size
rt 180
arcr 90 2*:size
end
to fill_it
setfc :i
pu lt 45 bk :size/2
fill
fd :size/2 rt 45 pd
end
to procs
ed[main flower leaf fill_it procs]
end
--------------------
to main ; Chain
3d_frame
sqrl
sqrr
touch
end
to sqrl
sphc -74 0 45 7 sqr 72
sph -55 0 45 sqr 45
sphc -70 0 0 6 setfc 6 fill
end
to sqrr
sphc -27 0 45 7 sqr 72
sph -8 0 45 sqr 45
sphc -17 0 0 4 setfc 4 fill
sp 70 0 setfc 4 fill
end
to sqr :size
repeat 4[fd :size rt 90]
end
to touch
sphc 0 15 -45 4 setfc 4 fill
sp 0 9 fd 13
sp 9 19 fd 13
setpc 6
sp 0 -27 fd 12
sp 9 -17 fd 12
end
to procs
ed[main sqrl sqrr sqr touch procs]
end
--------------------
to main ; Heart
3d_frame
for[ang 0 179 .5][
setxy(-2-60*sin :ang)(-25-100*cos :ang+60) draw]
for[ang 180 359 .5][
setxy(-2-60*sin :ang)(-25-100*cos :ang-60) draw]
end
to draw
pu setx xcor+15 pd
setpc 7 setx xcor+2 setx xcor-2 ; right edge
setpc 1 setx xcor-30 ; body color
setpc 1 setx xcor-2 setx xcor+2 ; left edge
setpc 7 setx xcor+15 ; body color
end
to procs
ed[main draw procs]
end
--------------------
to main ; MgnDvd1 by Olga
3d_frame
setpensize[2 2]
sph -40 -23 30 draw 80
end
to draw :amax
repeat 6[do 1 :amax fd :amax rt 60]
end
to do :a :amax
if :a>:amax[stop]
setpc(se random 256 random 256 random 256)
fd :a rt 120
fd :a+1 rt 120
fd :a+2 rt 120
do :a+3 :amax
end
to procs
ed[main draw do procs]
end
--------------------
to main ; Iris
3d_frame setpc 7
pu setx -9 pd
repeat 6[seth 60*(repcount-1) shape[]]
pu home pd
circle 79
pu fill_it
end
to shape :ll
push "ll pos push "ll heading arcr 90 60
pu seth pop "ll setpos pop "ll pd arcr 60 9
end
to fill_it
repeat 6[fd 55 setfc repcount fill bk 55 rt 60]
end
to procs
ed[main shape fill_it procs]
end
--------------------
to main ; muhammad
3d_frame
sp 80 -80
setpc 4 setpensize[9 9] do 20
setpc 6 setpensize[4 4] do 20
end
to do :size
repeat 4[draw :size pu bk 4*:size rt 90 bk 2*:size pd]
end
to draw :size
muh
fd 2*:size rt 180
muh
end
to muh
repeat 4[fd :size lt 90]
lt 90 fd 2*:size rt 90 fd :size
lt 90 fd 2*:size bk 2*:size
rt 90 bk :size lt 90 fd 2*:size
end
to procs
ed[main do draw muh procs]
end
--------------------
to main ; MD Star by Lev and Olga
3d_frame
resett 85
repeat 3[
setturtle 0 move 1 3 rt 120
setturtle 1 move 2 4 rt 120]
setturtle 0 setpc 1 lt 120 fd 1 rt 120 half_move 1 3
end
to resett :a
setturtle 0
pu home seth -60 fd :a seth 90 ht
setpensize[0 15] pd
setturtle 1
pu home seth 0 fd :a seth 150
ht
setpensize[0 15] pd
make "side :a * sqrt 3
make "step :side / 30
end
to move :c1 :c2
repeat 15[
setpc :c1 fd :step setpc :c2 fd :step
]
end
to half_move :c1 :c2
repeat 7[
setpc :c1 fd :step setpc :c2 fd :step
]
setpc :c1 fd :step
end
to procs
ed[main resett move half_move procs]
end
--------------------
to main ; Trefoil Weave by Mike Sandy
cs pu ht
3d_frame ;REMOVE THIS FOR LARGER PLOT
aa 2 2 8 48 ;CURVE IN FRAME PARAMENTERS
;TRY aa 2 2 15 100
end
to aa :pcol :c.incr :psize :size
; :pcol COLOUR OF 1ST CURVE
; :c.incr DETERMINES COLOUR OF NEXT CURVE
; :psize PENSIZE
; :size OVERALL SIZE OF PLOT
;The strands of a design are split into segments. At the centre of
;each segment lies an overlap, so that there are 2 segments per overlap;
;one for the upper strand (k=-1) and one for the lower one(k=1).
;The procedure firsts plots all those segments with k=1 and plots those
;with k=-1 on return from the recursion.
;Any number of curves can be included but they must be accessed within
;the weave procedure.
do "x "y :pcol :psize :size*1.10 2 3 .8 0 1 1
end
to do :fx :fy :pcol :psize :fsize :rs :rl :h :offset :t :k
; :fx :fy CURVE PROCEDURES X=F(ANGLE) Y=G(ANGLE)
; :rs :rs :h PARAMETERS OF CURVE
; :offset ANGLE OFFSET FOR START OF CURVE
; :t CONTROLS WHICH CURVE IS BEING PLOTTED
; :k DETERMINES WHETHER SEGMENT IS UNDERNEATH (+/-1)
let[[psize.l (list 0 :psize)]
[dr :rl-:rs]
[dist 0]
[a.incr 1] ;DETERMINES SMOOTHNESS OF SEGMENT. INCREASE
;FOR FASTER PLOTTING
[pf 1.75] ;DETERMINES POSITION OF EDGING
[a1 73][a2 98]
[b1 64][b2 92]
[seg.arr ifelse :t=1
[listtoarray (list 0
:a1 :a2 120
240-:a2 240-:a1 240
240+:a1 240+:a2 360
480-:a2 480-:a1 480
480+:a1 480+:a2 600
720-:a2 720-:a1 720)]
[listtoarray (list 0
:b1 :b2 120 240-:b2 240-:b1 240
240+:b1 240+:b2 360 480-:b2 480-:b1 480
480+:b1 480+:b2 600 720-:b2 720-:b1 720)]
]
[arr.len count :seg.arr]
[rot.l []][rot1.l []]
]
weave "x "y 1 :pcol :t :k
end
to rotate :x :y :ang
op (list :x*(cos :ang)-:y*sin :ang
:x*(sin :ang)+:y*cos :ang)
end
to weave :fx :fy :seg.num :pcol :t :k
(if and :seg.num=:arr.len
:t=2[stop])
(if :seg.num=:arr.len
[;stop
do "x "y :pcol+:c.incr :psize
:size*1.22 :rs :rl .30 60 :t+1 1
stop])
localmake "posn (list pos heading) ;SAVES POSITION FOR RECURSION RETURN
if :k=-1[(plot.curve "x "y
item :seg.num :seg.arr
item :seg.num+1 :seg.arr 0)
weave :fx :fy :seg.num+1 :pcol :t -1*:k
]
setpos first :posn seth last :posn
(plot.curve :fx :fy item :seg.num :seg.arr
item :seg.num+1 :seg.arr 1) ;SEGMENT PLOTTED IF k=1 OTHERWISE
;ON RETURN FROM RECURSION k=-1 AND
;PREVIOUSLY BLANK SEGMENT WILL
;NOW BE PLOTTED
if :k=1[weave :fx :fy :seg.num+1 :pcol :t -1*:k stop
]
end
to plot.curve :fx :fy :a :ang.f :pen ;+/-1 ;PLOTS SEGMENT
if :a>:ang.f[stop]
plot.incr :fx :fy :a :pen
plot.curve :fx :fy :a+:a.incr :ang.f :pen
end
to plot.incr :fx :fy :ang :pen
(make "rot.l ;INCREMENT START COORDS
rotate run (list :fx :ang)
run (list :fy :ang)
:offset)
(make "rot1.l ;INCREMENT END COORDS
rotate run (list :fx :ang+:a.incr)
run (list :fy :ang+:a.incr)
:offset)
setpos :rot.l
make "dist distance :rot1.l
setpc :pcol setpensize (list 0 :psize)
if :pen>0[pd]
setpos :rot1.l pu ;PLOTS SEGMENT CENTRE
setpc 0
setpensize [0 2]
setpos :rot.l
seth towards :rot1.l
rt 90 fd :psize/:pf lt 90
if :pen>0[pd] fd :dist pu ;PLOTS EDGE
setpos :rot.l
lt 90 fd :psize/:pf rt 90
if :pen>0[pd] fd :dist pu ;PLOTS EDGE
end
to x :a
op :fsize*((:dr*cos :a)+:h*cos (:dr/:rs*:a))
end
to y :a
op :fsize*((:dr*sin :a)-:h*sin (:dr/:rs*:a))
end
.macro let :list
if empty? :list [op []]
op (list "local "first first :list
"make "first first :list
"run bf first :list
"let bf :list)
end
to procs
ed[main aa do
rotate
weave
plot.curve
plot.incr
x y
let
procs]
end
--------------------
to main ;3d! EPITROCHOID by Mike Sandy
;THIS PLOT WAS RUN ON 32-BIT TRUE COLOR
;IT SHOULD RUN ON 16-BIT HICOLOR
;IF NOT TRY INCREASING THE FIRST PARAMETER
; OF setpc ch.col pc 5 50 IN THE PROC
; PLOT.SEG
;TYPE PROCS TO EDIT
aaa 20 7 120
end
to aaa :r :d.pa :size
; :r RADIUS OF LUNE ARCS
; :d.pa DISTANCE BETWEEN LUNES
; :size OVERALL SIZE OF PLOT
;IT IS A MATTER OF TRIAL AND ERROR TO FIND
;VALUES WHICH GIVE SATISFACTORY PLOTS
;THERE IS A POSSIBILITY THAT SOME WILL
;PRODUCE COLOUR LEAKAGE
cs ht pu
let[[fc.l {[0 255 0][0 255 0]}] ;CHANGE THE COLORS HERE
;TO GET DIFFERENT COLORED SEGMENTS
]
reset
cs ht pu
setpensize[0 1]
;setsc[210 210 210]
aa "x "y 1 1 :fc.l
end
to aa :fx :fy :k :t :fcol.l
let[[rs 4][rl 3][h .7] ;PARAMETERS OF THE EPITROCHOID
[dr :rl-:rs]
[fc.num 1]
[ff 1.15]
[a.incr 5] ;ANGLE INCREMENT FOR EPITROCHOID
[a1 55]
[a2 105]
[seg.arr listtoarray (list 0 :a1 :a2 240
480-:a2 480-:a1
480 480+:a1 480+:a2 720
960-:a2 960-:a1
960 960+:a1 960+:a2 1200
:rs*360-:a2 :rs*360-:a1 :rs*360)
] ;START ANGLES OF SEGMENTS
[arr.len count :seg.arr]
[cf 1.27]
]
setpc [0 0 0]
weave :fx :fy 1 :k :t :fc.num
end
to weave :fx :fy :seg.num :k :t :fn
(if and :seg.num=:arr.len
:t=1[stop])
local[store]
make "store (list pos heading)
if :k=-1[(plot.seg :fx :fy ;WILL PLOT OVERLAP SEGMENTS ON RETURN
item :seg.num :seg.arr
item :seg.num+1 :seg.arr 0)
weave :fx :fy :seg.num+1 -1*:k :t :fc.num
]
setpos first :store seth last :store
make "fc.num :fn ;ENSURES THAT THE SEG. COLOUR
;IS MOSTLY! CORRECT ON RETURN
(plot.seg :fx :fy
item :seg.num :seg.arr
item :seg.num+1 :seg.arr 1)
if :k=1[weave :fx :fy :seg.num+1 -1*:k :t :fc.num stop
]
end
to plot.seg :fx :fy :ang1 :ang2 :pen
if or :ang1>:ang2 :ang1=:ang2[stop]
let[[x0 run (list :fx :ang1)]
[x1 run (list :fx :ang1+:a.incr)]
[y0 run (list :fy :ang1)]
[y1 run (list :fy :ang1+:a.incr)]
[posn (list :x1 :y1)]
[posn0 (list :x0 :y0)]]
setpos :posn0
seth towards :posn
let[[dist distance :posn]
[n 1+int (:dist/:d.pa-1)]
[f :dist/:r/:n]
[incr.ang arcsin :f/2]
[a.ang 180+2*:incr.ang]
[t.ang 90-:incr.ang]]
setpc ch.col pc 5 50 ;INCREASE 1ST PARAMETER IF THE
;UNDERLYING SEGMENT SHOWS THRO'
repeat :n[lune arc.centre :x0 :y0 :x1 :y1
:n repcount-1
arc.centre :x0 :y0 :x1 :y1
:n repcount
-1*:a.ang :pen]
plot.seg :fx :fy :ang1+:a.incr :ang2 :pen
end
to lune :posn1 :posn2 :a.ang :pen
local[store]
make "fc.num -1*:fc.num+3
setfc item :fc.num :fcol.l
;setpc ch.col pc 1 40
setpos :posn1
seth towards :posn2
if :pen=1[lt :t.ang
pd arc :a.ang :r pu
rt :t.ang]
make "store (list pos heading)
setpos :posn2
if :pen=1[lt :t.ang pd
arc :a.ang :r pu
rt :t.ang
fd (:ff-:f)*:r ;pause
(fill "true)
]
setpos first :store seth last :store
end
to ch.col :list :x :n
if emptyp :list[op[]]
if :x=0[op :list]
local[1st res div]
make "1st first :list
make "res remainder :x+:1st :n
make "div int (:x+:1st)/:n
op fput :res ch.col bf :list :x*:div :n
end
to arc.centre :x0 :y0 :x1 :y1 :n :k
op (list ((:n-:k)*:x0+:k*:x1)/:n
((:n-:k)*:y0+:k*:y1)/:n)
end
to x :a
op :size*((:dr*cos :a)+:h*cos (:dr/:rs*:a))
end
to y :a
op :size*((:dr*sin :a)-:h*sin (:dr/:rs*:a))
end
.macro let :list
if empty? :list [op []]
op (list "local "first first :list
"make "first first :list
"run bf first :list
"let bf :list)
end
to procs
ed[main aaa aa weave
plot.seg
lune
ch.col
arc.centre
x y
let
procs]
end
--------------------