LOGO-L> scarfing? (empalmes en espanol)

[fajoy@uio.satnet.net]

I don't know the right name in english but 
this is what I've been spending my time on.

It's about joining points with arcs. The radius 
of the first arc is arbitrary.

The program has lots of analitic geometry. It even
has a procedure to invert a matrix (in the easiest
way for the programmer and the hardest for the 
computer, though: A^(-1)=adj(A)/det(A)).

It starts with the "ini procedure. It has no error
checking whatsoever.
---

to angle :ps
localmake "ds map "direction pair :ps
localmake "ns apply "product map "norm :ds
localmake "ai arccos ((dotprod (map [-?] item 1 :ds) item 2 :ds) / :ns)
op ifelse (clockwise :ps) [360 - :ai] [:ai]
end

to clockwise :ps
localmake "ds map "direction pair :ps
localmake "pd1 perpend item 1 :ds
localmake "d2 item 2 :ds
op 0 < ((dotprod :pd1 :d2) / norm :pd1)
end

to cofactor :m :i :j
op (power (-1) (:i+:j)) * determinant minor :m :i :j
end

to coordinate :o :d :t
op (map "sum :o map [:t*?] :d)
end

to determinant :m
if and (1=count :m) (1=count first :m) [
	op first first :m
]
op dotprod ~
first :m ~
map [cofactor :m 1 #] first :m
end

to direction :ps
localmake "p1 item 1 :ps
localmake "p2 item 2 :ps
op (map "difference :p2 :p1)
end

to emulmat :e :m
op map [[row] map [[col] :e*:col] item # :m] :m
end

to ini
localmake "ptos [[10 10] [10 0] [-10 -10] [-10 15] [5 5] [-10 5] [0 10]]
localmake "ptos emulmat 5 :ptos

localmake "lins pair :ptos
localmake "angs triad :ptos
localmake "dlns map "perpend map "direction :lins
localmake "mlns map "midpoint :lins

localmake "append "false

foreach [.1 .15 .2 .26 .3 .35 .4 .45 .5] [[t0] 
;localmake "t0 .1
localmake "cwis "true

cs
for (list "lini 1 count :lins 1) [

	ifelse (:lini=1) [
		localmake "bwis "true
		localmake "cntp coordinate first :mlns first :dlns :t0
	] [
		localmake "bwis clockwise rotation (se (item :lini :lins) (list :cntp))
		localmake "cntp intersection :cntp :dirp item :lini :mlns item :lini :dlns
	]

	pu setpos :cntp
;	pd setpencolor 5 circle 10 setpencolor 0 

	make "cwis (xor :cwis :bwis) = clockwise rotation (se (item :lini :lins) (list :cntp))

	ifelse :cwis [
		seth towards first item :lini :lins 
		pd rt 180
		setpencolor 4 setpensize [4 4] arc 360-angle rotation (se (item :lini :lins) (list :cntp)) distance first item :lini :lins
	] [
		seth towards last item :lini :lins 
		pd rt 180
		setpencolor 4 setpensize [4 4] arc angle rotation (se (item :lini :lins) (list :cntp)) distance first item :lini :lins
	]
;	setpencolor 0 setpensize [1 1] circle distance first item :lini :lins

	localmake "dirp direction list :cntp last item :lini :lins

]

setheading 90
foreach :ptos [
	pu setpos ? 
	pd setpencolor 0 label #
	setpencolor 1 circle 3 
]
(gifsave "empalmar.gif 0 :append -1 4)
make "append "true

]
end

to intersection :o1 :d1 :o2 :d2
localmake "dm inverse transpose list (map [-?] :d1) :d2
localmake "om transpose (list (map "difference :o1 :o2))
localmake "t1 first first matmul :dm :om
op coordinate :o1 :d1 :t1
end

to inverse :m
localmake "det determinant :m
localmake "fc iseq 1 count :m
op map [[j] map [[i] (cofactor :m :i :j)/:det] :fc] :fc
end

to matmul :m1 :m2 [:tm2 transpose :m2]	; multiply two matrices
output map [[row] map [[col] dotprod :row :col] :tm2] :m1
end

to midpoint :ps
localmake "p1 item 1 :ps
localmake "p2 item 2 :ps
op (map "sum :p1 map [product ? .5] direction :ps)
end

to minor :m :i :j
op transpose filter [not #=:j] transpose filter [not #=:i] :m
end

to norm :v
op sqrt dotprod :v :v
end

to pair :l
localmake "pairs []
for (list "i 1 (count :l)-1 1) [
	queue "pairs list item :i :l item :i+1 :l
]
op :pairs
end

to perpend :dir
localmake "c1 item 1 :dir
localmake "c2 item 2 :dir
op list :c2 (-:c1)
end

to rotation :l
op lput first :l butfirst :l
end

to transpose :m
localmake "mt []
repeat count first :m [
	queue "mt map [item repcount ?] :m 
]
op :mt
end

to triad :l
localmake "triads []
for (list "i 1 (count :l)-2 1) [
	queue "triads (list item :i :l item :i+1 :l item :i+2 :l)
]
op :triads
end

to xor :p :q
op and or not :p :q or :p not :q
end


The following section of this message contains a file attachment
prepared for transmission using the Internet MIME message format.
If you are using Pegasus Mail, or any another MIME-compliant system,
you should be able to save it or view it from within your mailer.
If you cannot, please ask your system administrator for assistance.

   ---- File information -----------
     File:  empalmar.gif 
     Date:  19 Aug 1998, 1:01
     Size:  17056 bytes.
     Type:  GIF-image

empalmar.gif