\documentclass[12pt]{amsart}
\usepackage[letterpaper,margin=1in]{geometry}
\usepackage{natbib}
%include crossing.fmt
%format aU = "a{\Up}"
%format aD = "a{\Down}"
%format tU = "t{\Up}"
%format tD = "t{\Down}"
%format ouU = "\Varid{ou}{\Up}"
%format ouD = "\Varid{ou}{\Down}"
%format ssU = "\Varid{ss}{\Up}"
%format ssD = "\Varid{ss}{\Down}"
%format c0
%format x1
%format x2
%format x1'
%format x2'
%format y1
%format y2
%format y1'
%format y2'
%format cos_theta = "\Varid{cos}\theta "
%format cos_phi = "\Varid{cos}\phi "
%format sin_theta = "\Varid{sin}\theta "
%format sin_phi = "\Varid{sin}\phi "
%format cos = "\cos "
%format sin = "\sin "
%format tau0
%format tau1
%format z0
%format z1
%format w0
%format w1
%format c1
%format c2
%format a1
%format a2
%format b1
%format b2
%format r0
%format ou1
%format ou2
\begin{document}
\mathindent 2\parindent
\section{Preliminaries}
\begin{code}
{-# OPTIONS -W #-}
{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, Rank2Types #-}
module Crossing where
import Control.Monad.State
import Data.Monoid (Monoid(..))
import Numeric (showFFloat)
\end{code}
We define a data type isomorphic to pairs, to express that one thing is
above another spatially. For example, two threads might grow rightward in
parallel, one above the other.
\begin{code}
data Stack above below = Stack above below deriving Show
\end{code}
Given a list of things (such as threads ordered from top to bottom), we
often want to pick out one or two of them by index and change those few
while leaving the rest intact.
\begin{code}
at :: Int -> ([a] -> [a]) -> ([a] -> [a])
at i f xs = ys ++ f zs where (ys, zs) = splitAt i xs
at1 :: Int -> (a -> a) -> ([a] -> [a])
at1 i f = at i (\(x:zs) -> f x : zs)
at2 :: Int -> (Stack a a -> Stack a a) -> ([a] -> [a])
at2 i f = at i (\(x:y:zs) -> let Stack x' y' = f (Stack x y) in x':y':zs)
\end{code}
\section{Weaving}
Weaving is basically the process of taking a list of crossings and following
those commands to permute a list of threads. A crossing is basically an
command to swap two adjacent threads, so the two threads to swap are
identified by a single integer index into the list of threads. A crossing
is either positive (right-handed, |Positive|) or negative
(left-handed, |Negative|).
\begin{code}
data PN = Positive | Negative deriving Show
\end{code}
Each thread records the history of how it has been swapped with other
threads. The history is a list of |Signal|s, one per swap experienced by
the thread (from most recent to most ancient---that is, in reverse order).
\begin{code}
data Signal c a = Signal OU c a deriving Show
data Thread c a t = Thread t [Signal c a] deriving Show
instance Functor (Thread c a) where fmap f (Thread t ss) = Thread (f t) ss
\end{code}
The most important thing that a |Signal| records is whether the thread
crossed \emph{under} another thread (|Under|) or not (|Over|). This
information has type |OU|. At each crossing, one thread goes over the
other, depending on the sign of the crossing.
\begin{code}
data OU = Over | Under deriving (Eq, Show)
ouU, ouD :: PN -> OU
ouU Positive = Under
ouU Negative = Over
ouD Positive = Over
ouD Negative = Under
\end{code}
A crossing can also contain information such as its location and the tangent
directions of the two threads.
Between the histories of the two threads, the location of the crossing is
shared whereas the tangent directions are split. In other words, each
|Signal| records one crossing location (the same between the two threads, of
type~|c|) and one tangent direction (different between the two threads, of
type~|a|).
Actually, weaving operates not on a list of |Thread|s but on a list of
|Maybe Thread|s. The reason is that sometimes we want to imagine that a
thread is there (and swap it with other threads) but not draw it yet. We
represent such an imaginary thread by |Nothing|. When a real thread crosses
an imaginary thread, the real thread always goes over (|Over|), so no gap is
drawn. (The first state component below, of type~|c|, is explained shortly
with |advance|.)
\begin{code}
type M c a t = State (c, [Maybe (Thread c a t)])
crossing :: Monoid c => Int -> PN -> c -> Stack a a -> M c a t ()
crossing i pn c (Stack aU aD) = modify (\(c0, threads) -> (c0, at2 i (f c0) threads)) where
f c0 (Stack (Just (Thread tD ssD)) (Just (Thread tU ssU))) = Stack (Just (Thread tU (Signal (ouU pn) (mappend c0 c) aU : ssU))) (Just (Thread tD (Signal (ouD pn) (mappend c0 c) aD : ssD)))
f c0 (Stack (Just (Thread tD ssD)) Nothing) = Stack Nothing (Just (Thread tD (Signal Over (mappend c0 c) aD : ssD)))
f c0 (Stack Nothing (Just (Thread tU ssU))) = Stack (Just (Thread tU (Signal Over (mappend c0 c) aU : ssU))) Nothing
f _ (Stack Nothing Nothing) = Stack Nothing Nothing
\end{code}
Furthermore, weaving actually processes not a just list of crossings but
more generally a list of commands. Crossings are by far the
most common kind of commands, but there are many other kinds.
An |advance| command shifts all future crossing locations by the specified
amount, as if that much space has been consumed by the weaving. The amount to
shift is the first state component in the |M| monad.
\begin{code}
advance :: Monoid c => c -> M c a t ()
advance c = modify (\(c0, threads) -> (mappend c0 c, threads))
\end{code}
A |through| command forces a thread to go through a location without crossing
any other thread.
\begin{code}
through :: Monoid c => Int -> c -> a -> M c a t ()
through i c a = modify (\(c0, threads) -> (c0, at1 i (fmap (f c0)) threads)) where
f c0 (Thread t ss) = Thread t (Signal Over (mappend c0 c) a : ss)
\end{code}
A |begin| command turns an imaginary thread into a real one---in other words,
puts the pen down. The second argument to |begin| (of type~|t|) specifies
information about the new real thread such as its identity and stroke color
and whether its two ends should be connected to form a loop.
\begin{code}
begin :: Eq t => Int -> t -> M c a t ()
begin i t = modify (\(c0, threads) -> (c0, at1 i f threads)) where
f (Just _) = error ("Thread already begun at " ++ show i)
f Nothing = Just (Thread t [])
\end{code}
Dually, an |end| command raises the pen, by moving a real thread to the end of
the list and putting an imaginary thread where the real thread was.
\begin{code}
end :: Eq t => Int -> t -> M c a t ()
end i t = modify (\(c0, threads) -> (c0, f (splitAt i threads))) where
f (above, thread@(Just (Thread t' _)):below)
| t == t' = above ++ Nothing : below ++ [thread]
| otherwise = error ("Different thread begun at " ++ show i)
f (_, Nothing:_) = error ("Thread never begun at " ++ show i)
f (_, []) = error ("Thread index " ++ show i ++ " out of range")
\end{code}
To carry out a command, we typically start with no shift and a list full of
imaginary threads, and do not care about the final shift.
\begin{code}
weave' :: Monoid c => M c a t () -> (c, [Maybe (Thread c a t)])
-> (c, [Maybe (Thread c a t)])
weave' = execState
weave :: Monoid c => M c a t () -> Int -> [Maybe (Thread c a t)]
weave cmd nThreads = snd (weave' cmd (mempty, replicate nThreads Nothing))
\end{code}
\section{Space}
Now we are ready to weave some threads in 2D\@@.
First we need some basic functions on 2D vectors.
\begin{code}
type Coord = Double
data Coords = C Coord Coord
infixl 6 <+>, <->
infixl 7 <*, ), (<->) :: Coords -> Coords -> Coords
C x1 y1 <+> C x2 y2 = C (x1 + x2) (y1 + y2)
C x1 y1 <-> C x2 y2 = C (x1 - x2) (y1 - y2)
(<*), ( Coord -> Coords
C x y <* t = C (x * t) (y * t)
C x y Coords
neg (C x y) = C (negate x) (negate y)
normalize z = z Coord
norm (C x y) = sqrt (x * x + y * y)
instance Show Coords where
showsPrec p (C x y) = showParen (p > 10) (s x . showChar ',' . s y)
where s = showFFloat (Just 5)
instance Monoid Coords where
mempty = C 0 0
mappend = (<+>)
\end{code}
The following function |arg| takes two vectors as arguments and computes the $\cos$
and $\sin$ of the angle counterclockwise from the second vector to the
first.
\begin{code}
arg :: Coords -> Coords -> Coords
arg (C x1 y1) (C x2 y2) = normalize (C (x1 * x2 + y1 * y2) (y1 * x2 - x1 * y2))
\end{code}
As promised, we record at each crossing the location and the tangent
directions of the two threads. We record the pen color of each thread as a
string. We also record whether the two ends of each thread should be
connected to form a loop.
\begin{code}
type M_ t = M Coords Coords t
type Signal_ = Signal Coords Coords
type Thread_ = Thread Coords Coords
data OC = Open | Closed deriving (Eq, Show, Read)
data Paint = Paint String OC deriving (Eq, Show, Read)
paint, red, orange :: OC -> Paint
paint = Paint ""
red = Paint "red"
orange = Paint "orange"
\end{code}
We draw a thread by alternating between cubic B\'ezier segments (between
crossings) and straight line segments (at crossings; only if |Over|, not if
|Under|). The B\'ezier control points are chosen as by
\citet{hobby-smooth}. The length of the straight line segment is twice the
length of the tangent direction vector specified. At each of the two ends
of a thread is an additional line segment, whose length is |stub|.
\begin{code}
stub :: Coord
stub = 5
hobby :: Coords -> Coords -> Coords -> Coords -> (Coords, Coords)
hobby z0 z1 w0 w1 = ( z0 <+> w0 <* (rho /( 3*tau0) * n/norm w0),
z1 <+> w1 <* (sigma /(- 3*tau1) * n/norm w1) ) where
d = z1 <-> z0
n = norm d
C cos_theta sin_theta = arg w0 d
C cos_phi sin_phi = arg d w1
a = sqrt 2
b = 1/16
c = (3 - sqrt 5)/2
alpha = a * (sin_theta - b * sin_phi) * (sin_phi - b * sin_theta) * (cos_theta - cos_phi)
rho = (2 + alpha) / (1 + (1 - c) * cos_theta + c * cos_phi )
sigma = (2 - alpha) / (1 + (1 - c) * cos_phi + c * cos_theta )
tau0 = 1
tau1 = 1
\end{code}
It is handy to transform thread coordinates by a function from
$\mathbb{R}^2$ to $\mathbb{R}^2$. To transform tangent directions along
with crossing locations, we need the function to return its own partial
derivatives.
\begin{code}
transform :: (Coords -> (Coords, Coords, Coords)) -> [Signal_] -> [Signal_]
transform f ss = [ Signal ou cc (a' <* (norm a / norm a'))
| Signal ou c a@(C ax ay) <- ss,
let (cc, c'x, c'y) = f c
a' = c'x <* ax <+> c'y <* ay ]
\end{code}
We can transform a picture on a cylinder into a picture on an annulus, to see
the final result of a construction. To this end, the |circular| command
executes a subcommand and transforms the result so that the threads go around a
circle and their ends connect to each other according to their initial and
final positions in the thread list. In other words, the threads are
concatenated according to how their end points are identified along the seam of
the cylinder. The circumference of the circle and the phase along the circle
are determined by the total |advance| amount in the subcommand: the straight
line segment between the origin and the total |advance| amount will be curled
up into a circle while preserving the total length and the initial and final
tangent direction.
\begin{code}
circular :: (forall t'. M_ t' ()) -> M_ t ()
circular cmd = modify (\(c0, threads) -> (c0, zipWith (g c0) threads [0..]))
where (c1, threads1) = weave' cmd (mempty, [Just (Thread i []) | i <- [0..]])
g _ Nothing _ = Nothing
g c0 (Just (Thread t ss)) i = Just (Thread t (transform (f c0) (loop i) ++ ss))
loop i = ss ++ go j
where Just (Thread j ss) = threads1 !! i
go j | i == j = []
| otherwise = ss ++ go k
where Just (Thread k ss) = threads1 !! j
p = norm c1
C rc rs = c1 C rs rc <* y
t = x' / p
r = y' + r0
s = sin (2 * pi * t)
c = cos (2 * pi * t)
x'' = r * s
y'' = r * c - r0
d (C dx dy) = let C dx' dy' = C rc (-rs) <* dx <+> C rs rc <* dy
dt = dx' / norm c1
dr = dy'
ds = 2 * pi * dt * c
dc = -2 * pi * dt * s
dx'' = dr * s + r * ds
dy'' = dr * c + r * dc
in C rc rs <* dx'' <+> C (-rs) rc <* dy''
in (c0 <+> C rc rs <* x'' <+> C (-rs) rc <* y'', d (C 1 0), d (C 0 1))
\end{code}
We use rectangles to track the bounding box of a picture.
\begin{code}
data Rect = Rect Coords Coords deriving Show
data Bounds = Empty | Nonempty Rect deriving Show
instance Monoid Bounds where
mempty = Empty
mappend Empty b = b
mappend b Empty = b
mappend (Nonempty (Rect (C x1 y1) (C x2 y2))) (Nonempty (Rect (C x1' y1') (C x2' y2'))) =
Nonempty (Rect (C (min x1 x1') (min y1 y1')) (C (max x2 x2') (max y2 y2')))
class HasBounds a where bounds :: a -> Bounds
instance HasBounds Signal_ where
bounds (Signal _ c a) = Nonempty (Rect (c <-> d) (c <+> d))
where C dx dy = a <* (1 + stub / norm a)
d = C (abs dx) (abs dy)
instance HasBounds a => HasBounds [a] where
bounds = mconcat . map bounds
instance HasBounds (Thread_ t) where
bounds (Thread _ signals) = bounds signals
instance HasBounds a => HasBounds (Maybe a) where
bounds = maybe Empty bounds
\end{code}
\section{SVG output}
The function |path| draws a thread history as an SVG path. If the first
argument is |Closed|, then |path| draws a closed thread (which requires a
closed SVG path if and only if there is no gap (|Under|) in the thread).
\begin{code}
path :: OC -> [Signal_] -> String
path Open [] = ""
path Open (Signal ou c a : ss) =
'M' : show (c <+> a <* (1 + stub / norm a)) ++
case ou of Over -> path' Over c a ss True
Under -> 'L' : show (c <+> a) ++ path' Under c a ss True
path Closed ss =
case span (\(Signal ou _ _) -> ou == Over) ss of
([], []) -> ""
(s@(Signal Over c a) : rest, []) -> path' Under c a (rest++[s]) False ++ ['Z']
(initial, s@(Signal Under c a) : rest) -> path' Under c a (rest++initial++[s]) False
_ -> error "Internal error: unexpected pattern-match failure"
path' :: OU -> Coords -> Coords -> [Signal_] -> Bool -> String
path' _ _ _ [] False = ""
path' ou c a [] True =
(case ou of Over -> ""; Under -> 'M' : show (c <-> a)) ++
'L' : show (c <-> a <* (1 + stub / norm a))
path' ou1 c1 a1 (Signal ou2 c2 a2 : ss) finalStub =
(case ou1 of Over -> 'L'; Under -> 'M') : show (c1 <-> a1) ++
'C' : show b1 ++ ' ' : show b2 ++ ' ' : show (c2 <+> a2) ++
path' ou2 c2 a2 ss finalStub
where (b1, b2) = hobby (c1 <-> a1) (c2 <+> a2) (neg a1) (neg a2)
\end{code}
The following function draws a bunch of threads as an SVG document.
\begin{code}
svg :: [Maybe (Thread_ Paint)] -> String
svg threads = unlines
$ ("" ]
where scale = 5
margin = 2
(C tx ty, C width height) =
case bounds threads of
Empty -> (C 0 0, C 0 0)
Nonempty (Rect (C x1 y1) (C x2 y2)) ->
( C (margin-x1) (-margin-y2),
C (x2-x1+2*margin) (y2-y1+2*margin) <* scale)
\end{code}
We can also put the same picture in TikZ\@@.
\begin{code}
tikz :: [Maybe (Thread_ Paint)] -> String
tikz threads = unlines
$ "\\begin{tikzpicture}[line width=.8pt]"
: [ "\\draw " ++ options ++ "svg \"" ++ path oc ss ++ "\";"
| Just (Thread (Paint paint oc) ss) <- threads,
let options = if null paint then "" else "[draw=" ++ paint ++ "] " ]
++ [ "\\end{tikzpicture}%" ]
\end{code}
\bibliographystyle{mcbride}
\bibliography{ccshan}
\end{document}