aUCBLogo Demos and Tests / woven_patterns

to woven_patterns
erns
(ss 0.8)
; local[bgo_shuffle bgo bnew.list bweave
;      sfactor smultiplier sdilation smodulus spoints sp_size ]
my_f=frame [][my_window] wxRESIZE_BORDER+wxCAPTION [10 50][250 200]
bsizer=BoxSizer wxVERTICAL
bshuffle=(button my_f [go_shuffle][go_shuffle updategraph] wxBU_LEFT [0 0][60 20])
bweave=(button my_f [weave][weave updategraph] wxBU_LEFT [65 0][60 20])
bgo=(button my_f [go][go updategraph] wxBU_LEFT [150 0][60 20])
BoxSizerAdd bsizer bshuffle 1 wxEXPAND 0
BoxSizerAdd bsizer bweave 1 wxEXPAND 0
BoxSizerAdd bsizer bgo 1 wxEXPAND 0
FrameSetSizer my_f bsizer
FrameSetClientSize my_f 100 100
make "factor 2
make "multiplier 41
make "dilation 20
make "modulus 7
make "points 5
make "p_size 3
make "mult []
make "shuff iseq 1 :modulus
end

to centre_plot :p_list
local[len p 2nd 1st xmin xmax ymin ymax]
make "len count :p_list
make "p first :p_list
make "1st first :p
make "2nd last :p
make "xmin :1st
make "xmax :1st
make "ymin :2nd
make "ymax :2nd
op h_centre_plot :p_list
end

to extend :n :list#
if :n==0[op[]]
op se :list# extend :n-1 :list#
end

to gen_list :n
op h_gen 1 :n []
end

to go
cs
if not :mult==:multiplier[make "mult :multiplier new_list]
local "ang0 make "ang0 :multiplier*360/((1+:factor)*:modulus*:points)
make "ang_list list :ang0 :factor*:ang0
make "len_ang_list count :ang_list
local [f_list p points_list p_list]
make "f_list extend :points se :shuff reverse :shuff
make "p [] make "points_list []
ht pu home
setpc 1 setpensize list 0 3
make "start_pos pos
make "p_list fput :start_pos trim_p_list plot 1 :f_list
setpos centre_plot :p_list
make "start_pos pos
make "p_list fput :start_pos trim_p_list plot 1 :f_list
plot1 0 :p_list pu
;make "p_pr_list make_p_pr_list :p_list
make "pf_pr_list modify_pf_list make_pf_pr_list make_p_pr_list :p_list
end

to go_shuffle
if not :mult==:multiplier[make "mult :multiplier new_list] ;
shuff = my_shuffle :shuff
go
show :shuff
end

to h_centre_plot :p_list
if empty? :p_list[op list 0-(:xmin+:xmax)/2 0-(:ymin+:ymax)/2]
local[1st x y] make "1st first :p_list
make "x first :1st make "y last :1st
if :xmin>:x[make "xmin :x]
if :xmax<:x[make "xmax :x]
if :ymin>:y[make "ymin :y]
if :ymax<:y[make "ymax :y]
op h_centre_plot bf :p_list
end

to h_gen :k :n :list#
local "v make "v remainder :k :n
if :v==0[op :list#]
op h_gen :k+1 :n lput :v :list#
end

to h_make_pf :el :list# :k1 :k2 :p_list :flag
if empty? bf :p_list[ stop]
if empty? :list# [h_make_pf first :p_list bf bf :p_list :k1 + 1 :k1 + 3 bf :p_list 1 stop]
local "soln make "soln solve :el first :list#
(if not empty? :soln
     [local[1st 2nd]
      make "1st first :soln make "2nd last :soln
      (if and (and  0<:1st  :1st<1) (and  0<:2nd :2nd<1)
         [make "pf_list subst :1st :k1 :pf_list
          make "pf_list subst :2nd :k2 :pf_list
         ])
     ])
h_make_pf :el bf :list# :k1 :k2 + 1 :p_list 1
end

to h_sort :el :list#
if empty? :list#[op (list :el)]
if :el<first :list#[op fput :el :list#]
op fput first :list# h_sort :el bf :list#
end

to h_weave :ci :pf_list
if empty? :pf_list[stop]
local[1st p f p1 p2]
make "1st first :pf_list
make "p first :1st make "f last :1st
make "p1 first :p make "p2 last :p
if not empty? :f[make "ci 1-:ci]
if :ci==0[h_weave 0 bf :pf_list]
segment :p1 :p2
if :ci==1[h_weave 1 bf :pf_list stop]
end

to make_initial_pf_pr_list :list#
if empty?  :list#[op []]
op fput list  first :list#  [] make_initial_pf_pr_list bf :list#
end

to make_p_pr_list :list#
if empty? bf :list#[op[]]
op fput list first :list# first bf :list# make_p_pr_list bf :list#
end

to make_pf_pr_list :p_pr_list
local "pf_list
make "pf_list make_initial_pf_pr_list :p_pr_list ;GENERATED BY PLOT AND TRIMMED
h_make_pf first :p_pr_list bf bf :p_pr_list 1 3 bf :p_pr_list 0
op :pf_list
end

to modify_item  :f_list
if empty? bf :f_list[op[]]
local[f1 f2 fm]
make "f1 first :f_list
make "f2 first bf :f_list
make "fm (:f1 + :f2) / 2
op  fput  ( :p1*(1 - :fm)  + :p2*:fm ) modify_item bf :f_list
end

to modify_pf_list :pf_list
if empty? :pf_list [op[]]
local[1st p_list f_list p1 p2]
make "1st first :pf_list
make "p_list first :1st
make "f_list my_sort last :1st
make "p1 first :p_list
make "p2 last :p_list
if empty? :f_list[op fput :1st modify_pf_list bf :pf_list]
make "p_list fput :p1 lput :p2 modify_item :f_list
;show :p_list stop
(op se pf_extend :p_list  :f_list  modify_pf_list bf :pf_list)
end

to my_remove :i :list#
if empty? :list#[op[]]
if :i==first :list#[op bf :list#]
op fput first :list# my_remove :i bf :list#
end

to my_shuffle :list#
if empty? :list#[op[]]
local "i i=pick :list#
op fput :i my_shuffle my_remove :i :list#
end

to my_sort :list#
if empty? :list#[op[]]
if empty? bf :list#[op :list#]
op h_sort first :list# my_sort bf :list#
end

to new_list
ct
make "shuff pick_list :modulus gen_list :modulus
show :shuff
end

to pf_extend :p_list :f_list
if empty? bf :p_list[op[]]
(op fput list (list first :p_list first bf :p_list)
               (list first :f_list)
          pf_extend bf :p_list :f_list)
end

to pick_list :n :list#
if :n==0[op[]]
local "v make "v pick :list#
op fput :v pick_list :n-1 :list#
end

to plot :k :f_list
if empty? :f_list[op[]]
lt item 1+remainder :k :len_ang_list :ang_list
fd :dilation*first :f_list
op fput pos plot :k+1 bf :f_list
end

to plot1 :k :p_list
if empty? :p_list[stop]
setpos first :p_list
pd
plot1 :k+1 bf :p_list
end

to segment :p1 :p2
local "d
t1=newturtle t2=newturtle
setturtle t1 ht pu setpos :p1
seth towards :p2
make "d distance :p2
setturtle t2 ht pu setpos :p1
seth towards :p2
setpensize list 0 2 setpc 1
pu lt 90 fd  ifelse 1==remainder :p_size 2[1+int :p_size/2][1+:p_size/2]
rt 90 pd fd :d pu
rt 90 fd  ifelse 1==remainder :p_size 2[2+2*int :p_size/2][2.5+:p_size]
rt 90 pd fd :d pu
setturtle t1
setpensize list :p_size :p_size
setpc 4 pd fd :d pu
end

to solve :pr1 :pr2
local[p1 p1 p3 p4 x1 y1
       x2 y2 x3 y3 x4 y4
       f1 f2 p0 p  delta]
make "p1 first :pr1
make "p2 last :pr1
make "p3 first :pr2
make "p4 last :pr2
make "x1 first :p1
make "y1 last  :p1
make "x2 first :p2
make "y2 last  :p2
make "x3 first :p3
make "y3 last  :p3
make "x4 first :p4
make "y4 last  :p4
make "f1 0 make "p0 []  make "p []
make "f2 0  make "delta (:x2 - :x1) * (:y3 - :y4) - (:y2 - :y1) * (:x3 - :x4)
if  0.001 > abs :delta [op []]
make "f1 ((:x3 - :x1) * (:y3 - :y4) - (:y3 - :y1) * (:x3 - :x4)) / :delta
make "f2 ((:x2 - :x1) * (:y3 - :y1) - (:y2 - :y1) * (:x3 - :x1)) / :delta
op list :f1 :f2
end

to subst :f :k :pf_pr_list
if :k>count :pf_pr_list[op "ERROR]
(if :k==1
   [local "1st make "1st first :pf_pr_list
    (op fput list first :1st fput :f last :1st
             bf :pf_pr_list)
   ])
op fput first :pf_pr_list  subst :f :k-1 bf :pf_pr_list
end

to trim_p_list :p_list
if empty? :p_list[op[]]
if equal? :start_pos first :p_list[op (list first :p_list)]
op fput first :p_list trim_p_list bf :p_list
end

to weave
go
pu cs home
h_weave 1 :pf_pr_list
end