module Math.SelfAssembly.Baggins (
Tile,Program,runProgram,execProgram,simulate,
seed,
movex,movey,discreteVect,
repete,pump,
Cur(..),currentTile,nextTile,prevTile,
Dir(..),bind,rewindBy,rewindTo,eraseAfter,
Color,setColor,red,green,blue,black,
plot,PlotOptions(..),defaultPlot,
traceTile,tikzPlot
) where
import Control.Monad.State
import qualified Data.Map as M
import qualified Data.IntMap as IM
import qualified Data.IntSet as S
import Graphics.Rendering.Cairo hiding(scale)
import Foreign.Storable
import Data.Bits(shiftL,shiftR,(.&.),(.|.))
import System.IO
import Numeric
import Debug.Trace
data Tile=Tile {n::Int, s::Int, o::Int, e::Int,color::(Double,Double,Double)} deriving (Eq,Show)
sortTile::M.Map Int Tile -> (M.Map Int [Int], M.Map Int [Int], M.Map Int [Int], M.Map Int [Int])
sortTile t=
M.foldlWithKey' (\(mn,ms,mo,me) k a->
let { addm f m=
case M.lookup (f a) m of {
Nothing->M.insert (f a) [k] m;
Just x->M.insert (f a) (k:x) m
}
}
in
(addm n mn,addm s ms,addm o mo,addm e me)
)
(M.empty,M.empty,M.empty,M.empty) t
type Position=(Int,Int)
coup x y=(x,y)
uncoup p=p
incrx p=let (x,y)=uncoup p in coup (x+1) y
incry p=let (x,y)=uncoup p in coup x (y+1)
decrx p=let (x,y)=uncoup p in coup (x1) y
decry p=let (x,y)=uncoup p in coup x (y1)
posLookup=M.lookup
posInsert=M.insert
posFindWithDefault=M.findWithDefault
posFromList=M.fromList
posFoldlWithKey'=M.foldlWithKey'
simulate::Int->Int->[(Int,Int,Int)]->[(Int,Int)]->M.Map Int Tile->
IO (Int,Int,Int,Int,M.Map Position Int)
simulate nw nh seeds blockers tiles_=do {
let { (nn,ss,oo,ee)=sortTile tiles_;
intlen=sizeOf (0::Int);
coup x y=(x,y);
uncoup p=p;
incrx p=let (x,y)=uncoup p in coup (x+1) y;
incry p=let (x,y)=uncoup p in coup x (y+1);
decrx p=let (x,y)=uncoup p in coup (x1) y;
decry p=let (x,y)=uncoup p in coup x (y1);
};
let { simu !x0 !y0 !x1 !y1 grid []=return (x0,y0,x1,y1,grid);
simu !x0 !y0 !x1 !y1 grid (p:tl)=
if any (==p) blockers then simu x0 y0 x1 y1 grid tl else do {
let { (x,y)=uncoup p };
case posLookup p grid>>=(\t->M.lookup t tiles_) of {
Nothing->simu (min x x0) (min y y0) (max x x1) (max y y1) grid tl;
Just tt->do {
let { deterministe l@(_:_:_)=
putStrLn $ "Non-deterministic choice at position "++show (x,y)++": "
++show (map (\u->M.lookup u tiles_) l);
deterministe _=return () };
(nt,gr0)<-if y>=(nh1) then return ([],grid) else do {
let { pos=case posLookup (incry p) grid of {
Nothing->posFindWithDefault [] (n tt) ss;
_->[]
}
};
deterministe pos;
case pos of {
[]->return ([],grid);
(hh:_)->return ([(incry p)], posInsert (incry p) hh grid)
}
};
(st,gr1)<-if y<1 then return (nt,gr0) else do {
let { pos=case posLookup (decry p) gr0 of {
Nothing->posFindWithDefault [] (s tt) nn;
_->[]
}
};
deterministe pos;
case pos of {
[]->return (nt,gr0);
(hh:_)->return ((decry p):nt, posInsert (decry p) hh gr0)
}
};
(et,gr2)<-if x>=(nw1) then return (st,gr1) else do {
let { pos=case posLookup (incrx p) gr1 of {
Nothing->posFindWithDefault [] (e tt) oo;
_->[]
}
};
deterministe pos;
case pos of {
[]->return (st,gr1);
(hh:_)->return ((incrx p):st, posInsert (incrx p) hh gr1)
}
};
(ot,gr3)<-if x<1 then return (et,gr2) else do {
let { pos=case posLookup (decrx p) gr2 of {
Nothing->posFindWithDefault [] (o tt) ee;
_->[]
}
};
deterministe pos;
case pos of {
[]->return (et,gr2);
(hh:_)->return ((decrx p):et, posInsert (decrx p) hh gr2)
}
};
simu (min x0 x) (min y0 y) (max x1 x) (max y1 y) gr3 $!
tl++reverse ot
};
};
}
};
simu nw nh 0 0 (posFromList [(coup a b,c)|(a,b,c)<-seeds]) [coup a b | (a,b,_)<-seeds];
}
data PlotOptions=Plot { showGlues::Bool, showPaths::Bool, offset::Double, scale::Double, font::String, fontSize::Double }
defaultPlot=Plot { showGlues=True,offset=100,showPaths=False,scale=0.1, font="Arial",fontSize=0.18 }
plot::FilePath->PlotOptions->M.Map Int Tile->M.Map Position Int->IO()
plot file opts tiles_ grid=do {
let { scal=scale opts;
off=offset opts;
(nw,nh)=M.foldlWithKey (\(x,y) (x',y') _->(max x x',max y y')) (0,0) grid;
(w0,h0)=M.foldlWithKey (\(x,y) (x',y') _->(min x x',min y y')) (nw,nh) grid;
h=(fromIntegral $ nhh0+1)*scal+2*off;
w=(fromIntegral $ nww0+1)*scal+2*off };
withPDFSurface file w h $ \surface->renderWith surface $ do {
translate (fromIntegral w0*scal) (fromIntegral h0*scal);
selectFontFace (font opts) FontSlantNormal FontWeightNormal;
setFontSize $ fontSize opts*scal;
let { drawPicture pos tt tset=do {
let { (x,y)=uncoup pos };
case M.lookup tt tiles_ of {
Nothing->return ();
Just t->do {
let {(a,b,c)=color t} in
setSourceRGB a b c;
rectangle (off+scal*fromIntegral x)
(hoffscal scal*fromIntegral y)
scal scal;
closePath;
setLineWidth 0.01;
stroke;
if showGlues opts then do {
let {glueN=if n t<0 then "" else show $ n t;
glueS=if s t<0 then "" else show $ s t;
glueE=if e t<0 then "" else show $ e t;
glueO=if o t<0 then "" else show $ o t};
ten<-textExtents glueN;
tes<-textExtents glueS;
tee<-textExtents glueE;
teo<-textExtents glueO;
if showPaths opts then do {
setLineWidth 1;
if (n t>=0 && s t>=0) || (e t>=0 && o t>=0) then do {
(toN,toS)<-
if n t>=0 && s t>=0 then do {
moveTo (off+scal*(1/2+fromIntegral x)) (hoffscal*(fromIntegral y));
lineTo (off+scal*(1/2+fromIntegral x)) (hoffscal*(1+fromIntegral y));
return (False,False);
} else return (n t>=0,s t>=0);
(toE,toO)<-if e t>=0 && o t>=0 then do {
moveTo (off+scal*(fromIntegral x)) (hoffscal*(1/2+fromIntegral y));
lineTo (off+scal*(1+fromIntegral x)) (hoffscal*(1/2+fromIntegral y));
return (False,False)
} else return (e t>=0, o t>=0);
if toN then do {
moveTo (off+scal*(1/2+fromIntegral x)) (hoffscal*(1/2+fromIntegral y));
lineTo (off+scal*(1/2+fromIntegral x)) (hoffscal*(1+fromIntegral y));
} else return ();
if toS then do {
moveTo (off+scal*(1/2+fromIntegral x)) (hoffscal*(1/2+fromIntegral y));
lineTo (off+scal*(1/2+fromIntegral x)) (hoffscal*(fromIntegral y));
} else return ();
if toE then do {
moveTo (off+scal*(1/2+fromIntegral x)) (hoffscal*(1/2+fromIntegral y));
lineTo (off+scal*(1+fromIntegral x)) (hoffscal*(1/2+fromIntegral y));
} else return ();
if toO then do {
moveTo (off+scal*(1/2+fromIntegral x)) (hoffscal*(1/2+fromIntegral y));
lineTo (off+scal*(fromIntegral x)) (hoffscal*(1/2+fromIntegral y));
} else return ();
} else do {
if s t>=0 then
moveTo (off+scal*(1/2+fromIntegral x)) (hoffscal*(fromIntegral y))
else
if n t>=0 then
moveTo (off+scal*(1/2+fromIntegral x)) (hoffscal*(1+fromIntegral y))
else
if e t>=0 then
moveTo (off+scal*(1+fromIntegral x)) (hoffscal*(1/2+fromIntegral y))
else
if o t>=0 then
moveTo (off+scal*(fromIntegral x)) (hoffscal*(1/2+fromIntegral y))
else
return ();
lineTo (off+scal*(1/2+fromIntegral x)) (hoffscal*(1/2+fromIntegral y));
if e t>=0 then
lineTo (off+scal*(1+fromIntegral x)) (hoffscal*(1/2+fromIntegral y))
else
if o t>=0 then
lineTo (off+scal*(fromIntegral x)) (hoffscal*(1/2+fromIntegral y))
else
if n t>=0 then
lineTo (off+scal*(1/2+fromIntegral x)) (hoffscal*(1+fromIntegral y))
else
if s t>=0 then
lineTo (off+scal*(1/2+fromIntegral x)) (hoffscal*(fromIntegral y))
else
return ();
};
stroke;
setLineWidth 0.01;
} else return ();
moveTo (off+scal*(1/2+fromIntegral x)textExtentsWidth ten/2)
(hoffscalscal*fromIntegral y+textExtentsHeight ten+0.1*scal);
showText glueN;
let { yoff=textExtentsYbearing tes+textExtentsHeight tes };
moveTo (off+scal*(1/2+fromIntegral x)textExtentsWidth tes/2)
(hoffscalscal*(fromIntegral y1) yoff0.1*scal);
showText glueS;
save;
moveTo (off+scal*(fromIntegral x)) (hoffscalscal*(fromIntegral y1/2));
rotate $ pi/2;
(cx,cy)<-getCurrentPoint;
moveTo (cxtextExtentsWidth teo/2) (cy+textExtentsHeight teo+0.1*scal);
showText glueO;
moveTo (cxtextExtentsWidth tee/2) (cy+scal0.1*scal);
showText glueE;
restore;
} else return ()
};
};
return $ if tt>=0 then S.insert tt tset else tset
}
};
tset<-posFoldlWithKey' (\m k a->do {
m_<-m;
drawPicture k a m_
}) (return S.empty) grid;
if S.size tset < M.size tiles_ then
liftIO $ putStrLn $ "Warning: only "++show (S.size tset)++" out of "++
show (M.size tiles_)++" tiles used"
else return ();
};
}
defaultTile::Tile
defaultTile=Tile { n= 1,s= 2, o= 1, e= 2, color=(0,0,0) }
data St=State { lastGlue::Int, tiles::M.Map Int Tile, lastTile::Maybe Int, curColor::Color,
seeds::[(Int,Int,Int)] }
empty::St
empty=State { lastGlue=0,tiles=M.empty,lastTile=Nothing, curColor=black,seeds=[] }
type Program=State St
seed::Int->Int->Program ()
seed x y=do
st<-get
let s=if M.null $ tiles st then 0 else (1+(fst $ M.findMax $ tiles st))
put $ st { seeds=(x,y,s):seeds st,
lastTile=Just s,
tiles=M.insert s defaultTile $ tiles st }
move_::Bool->Int->Program ()
move_ vertical m=do
st<-get
let (lg,tiles0,connected)=case lastTile st of {
Nothing->(lastGlue st,tiles st,False);
Just x->case M.lookup x $ tiles st of {
Nothing->(lastGlue st,tiles st,False);
Just y->
if vertical then
if m>=0 then
(if n y<0 then lastGlue st+1 else n y,
M.insert x (y { n=if n y<0 then lastGlue st+1 else n y }) $ tiles st,
True)
else
(if s y<0 then lastGlue st+1 else s y,
M.insert x (y { s=if s y<0 then lastGlue st+1 else s y }) $ tiles st,
True)
else
if m>=0 then
(if e y<0 then lastGlue st+1 else e y,
M.insert x (y { e=if e y<0 then lastGlue st+1 else e y }) $ tiles st,
True)
else
(if o y<0 then lastGlue st+1 else o y,
M.insert x (y { o=if o y<0 then lastGlue st+1 else o y }) $ tiles st,
True)
}
}
t=if vertical then
if m>=0 then
[ defaultTile { n=if i==(lg+m1) then (1) else i+1,
s=if i==lg && not connected then (2) else i,
color=curColor st } | i<-[lg..(lg+m1)] ]
else
[ defaultTile { s=if i==(lgm1) then (2) else i+1,
n=if i==lg && not connected then (1) else i,
color=curColor st } | i<-[lg..(lgm1)] ]
else
if m>=0 then
[ defaultTile { e=if i==(lg+m1) then (2) else i+1,
o=if i==lg && not connected then (1) else i,
color=curColor st } | i<-[lg..(lg+m1)] ]
else
[ defaultTile { o=if i==(lgm1) then (1) else i+1,
e=if i==lg && not connected then (2) else i,
color=curColor st } | i<-[lg..(lgm1)] ]
nextTiles=foldl (\ts x->M.insert (if M.null ts then 0 else (1+fst (M.findMax ts))) x ts)
tiles0 t
put $ st { lastGlue=lg+abs m1,
lastTile=if M.null nextTiles then Nothing else (Just $ fst $ M.findMax nextTiles),
tiles=nextTiles }
movey::Int->Program ()
movey=move_ True
movex::Int->Program ()
movex=move_ False
repeat_::Int->Program ()->Program ()
repeat_ k m=if k<=0 then return () else do
m
repeat_ (k1) m
repete::Int->Program ()->Program ()
repete a b=do {
st0<-get;
repeat_ a b;
st1<-get;
put $ st1 { curColor=curColor st0 }
}
discreteVect::Int->Int->Program ()
discreteVect x0 y0=
let disc x y=
if x0==x then movey (y0y) else
if y0==y then movex (x0x) else
let xf=(fromIntegral x0/fromIntegral y0)*(fromIntegral y)
xx0=(fromIntegral x0/fromIntegral y0)*(fromIntegral (y+1))::Double
in
if (abs $ xffromIntegral (x+1)) <= (abs $ fromIntegral xxx0) then
if x0>x then do { movex 1; disc (x+1) y }
else do { movex (1); disc (x1) y }
else
if y0>y then do { movey 1; disc x (y+1) }
else do { movey (1); disc x (y1) }
in
disc 0 0
pump::Program ()->Program ()
pump m=do
st0<-get
m
st1<-get
put $ st1 { lastGlue=lastGlue st0 }
m
st2<-get
put $ st2 { lastGlue=lastGlue st0 }
m
st3<-get
let { (max0,_)=M.findMax $ tiles st0;
(max1,_)=M.findMax $ tiles st1;
(max2,_)=M.findMax $ tiles st2;
(m0,_)=M.split (max0+1) $ tiles st3;
(_,m1)=M.split max1 $ tiles st3;
(m2,_)=M.split (max2+1) m1;
t=M.foldlWithKey' (\m3 k a->M.insert (kmax1+max0) a m3) m0 m2
}
put $ st3 { tiles=t,curColor=curColor st0,lastTile=Just $ fst $ M.findMax t }
type Color=(Double,Double,Double)
red,green,blue,black::Color
red=(1,0,0)
green=(0,1,0)
blue=(0,0,1)
black=(0,0,0)
setColor::Color->Program ()
setColor col=do
st<-get
put $ st { curColor=col }
newtype Cur=Cur Int
currentTile::Program Cur
currentTile=do
st<-get
case lastTile st of
Nothing->error "currentTile not defined"
Just x->return $ Cur x
nextTile::Cur->Program Cur
nextTile (Cur a)=do
st<-get
let (_,v)=M.split a $ tiles st
if M.null v then error "no next tile defined" else return $ Cur $ fst $ M.findMin v
prevTile::Cur->Program Cur
prevTile (Cur a)=do
st<-get
let (u,_)=M.split a $ tiles st
if M.null u then error "no previous tile defined" else return $ Cur $ fst $ M.findMax u
rewindTo::Cur->Program ()
rewindTo (Cur t)=do
st<-get
put $ st { lastTile=Just t }
rewindBy::Int->Program ()
rewindBy n0=if n0<0 then error "rewind by negative amount" else do
st<-get
if M.null $ tiles st then error "rewind on empty tileset" else do
let { del i m k=
if i<0 then k else
let { ((a,_),m')=M.deleteFindMax m } in
del (i1) m' a;
m0=case lastTile st of { Nothing->tiles st;
Just a->fst $ M.partitionWithKey (\k _->k<=a) $ tiles st }
}
put $ st { lastTile=Just $ del n0 m0 0 }
data Dir=N | S | O | E
bind::Dir->Cur->Program ()
bind d (Cur t)=do
st<-get
case lastTile st of
Nothing->return ()
Just a->
case (M.lookup a $ tiles st, M.lookup t $ tiles st) of
(Just b, Just tt)->
let (nextTiles,nextGlue)=case d of
N->if s tt<0 then
(M.insert t (tt { s=lastGlue st+1 }) $
M.insert a (b { n=lastGlue st+1 }) $ tiles st,
lastGlue st+1)
else
(M.insert a (b { n=s tt }) $ tiles st,lastGlue st)
S->if n tt<0 then
(M.insert t (tt { n=lastGlue st+1 }) $
M.insert a (b { s=lastGlue st+1 }) $ tiles st,
lastGlue st+1)
else
(M.insert a (b { s=n tt }) $ tiles st,lastGlue st)
O->if e tt<0 then
(M.insert t (tt { e=lastGlue st+1 }) $
M.insert a (b { o=lastGlue st+1 }) $ tiles st,
lastGlue st+1)
else
(M.insert a (b { o=e tt }) $ tiles st,lastGlue st)
E->if o tt<0 then
(M.insert t (tt { o=lastGlue st+1 }) $
M.insert a (b { e=lastGlue st+1 }) $ tiles st,
lastGlue st+1)
else
(M.insert a (b { e=o tt }) $ tiles st,lastGlue st)
in
put $ st { tiles=nextTiles, lastGlue=nextGlue }
_->return ()
eraseAfter::Cur->Program ()
eraseAfter (Cur a)=do
st<-get
put $ st { tiles=fst $ M.split (a+1) $ tiles st }
runProgram::Program a->(a,[(Int,Int,Int)],M.Map Int Tile)
runProgram p=
let (a,b)=runState p empty in
(a,seeds b,tiles b)
execProgram::Program ()->([(Int,Int,Int)],M.Map Int Tile)
execProgram p=
let st=execState p empty in (seeds st,tiles st)
traceTile (Cur t)=do
st<-get
traceShow (M.lookup t $ tiles st) $ return ()
tikzTile::Tile->Double->Double->Double->String
tikzTile t sc x y=
"\\draw"++show (sc*x,sc*y)++"rectangle"++(show $ (sc*(x+1),sc*(y+1)))++";"++
(if o t>=0 then
"\\draw"++show (sc*x,sc*(y+0.5))++"node[anchor=west]{"++(show $ o t)++"};"
else "")++
(if n t>=0 then
"\\draw"++show (sc*(x+0.5),sc*(y+1))++"node[anchor=north]{"++(show $ n t)++"};"
else "")++
(if e t>=0 then
"\\draw"++show (sc*(x+1),sc*(y+0.5))++"node[anchor=east]{"++(show $ e t)++"};"
else "")++
(if s t>=0 then
"\\draw"++show (sc*(x+0.5),sc*y)++"node[anchor=south]{"++(show $ s t)++"};"
else "")
tikzPlot::FilePath->PlotOptions->M.Map Int Tile->M.Map Position Int->IO()
tikzPlot file opts tiles_ grid=
withFile file WriteMode $ \h->do {
let { s=scale opts / (10/fontSize opts);
s0=scale opts;
(x0,y0,x1,y1)=M.foldlWithKey (\(a,b,c,d) (x,y) _->(min a x,min b y,max c x,max d y)) (maxBound,maxBound,minBound,minBound) grid;
showf (x,y)="("++showFFloat (Just 4) x (","++showFFloat (Just 4) y ")")
};
hPutStr h $ "\\draw[use as bounding box,draw=none,fill=none]";
hPutStr h $ showf (fromIntegral x0*s0,fromIntegral y0*s0);
hPutStr h $ "rectangle";
hPutStr h $ showf (fromIntegral (x1+1)*s0,fromIntegral (y1+1)*s0);
hPutStr h $ ";\\begin{scope}[transform canvas={scale="++show (1*s)++"}]";
mapM_ (\((x,y),t)->
case M.lookup t tiles_ of {
Just tt->hPutStr h $ tikzTile tt (10/fontSize opts) (fromIntegral x) (fromIntegral y);
Nothing->return ()
}) $ M.toList grid;
hPutStrLn h $ "\\end{scope}";
}