remove unused dtTop field; fix warnings
[maximus:kjhf.git] / src / DataTape.hs
1 module DataTape(DataTape(), dataTape, get, modify, up, left, right, downLeft, downRight, isRightChild, getPointer, pretty) where
2
3 import Data.List(intersperse)
4 import Data.Map(Map)
5 import qualified Data.Map as M
6
7 default (Int)
8
9 data Cell = Cell{ cUp, cLeft, cRight, cDownLeft, cDownRight :: Maybe Int, cData :: Bool }
10   deriving (Read, Show)
11
12 cell :: Cell
13 cell = Cell Nothing Nothing Nothing Nothing Nothing False
14
15 data DataTape = DataTape{ dtCells :: Map Int Cell, dtPtr :: Int, _dtPosition :: [Bool] }
16
17 dataTape :: [Bool] -> DataTape
18 dataTape ps = DataTape (M.singleton 0 cell) 0 ps
19
20 get :: DataTape -> Bool
21 get (DataTape m p _) = cData (m M.! p)
22
23 modify :: (Bool -> Bool) -> DataTape -> DataTape
24 modify f dt@(DataTape m p _) = dt{ dtCells = M.update (\c -> Just c{ cData = f (cData c) }) p m }
25
26 merge :: Int -> Int -> DataTape -> DataTape
27 merge l r dt = dt{ dtCells = M.update (\c -> Just c{ cLeft  = Just l }) r
28                            . M.update (\c -> Just c{ cRight = Just r }) l
29                            $ dtCells dt }
30
31 isRightChild :: DataTape -> Bool
32 isRightChild dt = let dt' = downRight . up $ dt
33                   in dtPtr dt == dtPtr dt'
34
35 getPointer :: DataTape -> Int
36 getPointer dt = dtPtr dt
37
38 up :: DataTape -> DataTape
39 up dt@(DataTape m p (b:bs)) = case cUp (m M.! p) of
40   Just q  -> dt{ dtPtr = q }
41   Nothing -> let q = M.size m
42                  c = if b then cell{ cDownRight = Just p } else cell{ cDownLeft = Just p }
43                  n = M.update (\c0 -> Just c0{ cUp = Just q }) p m
44              in DataTape (M.insert q c n) q bs
45 up    (DataTape _ _ []    ) = error "DataTape.up: no more position data"
46
47 left :: DataTape -> DataTape
48 left dt@(DataTape m p _) = case cLeft (m M.! p) of
49   Just q  -> dt{ dtPtr = q }
50   Nothing -> let dt'@(DataTape m' u _) = up dt
51              in if cDownRight (m' M.! u) == Just p then                                        downLeft         $ dt' else
52                 if cDownLeft  (m' M.! u) == Just p then (\dt'' -> merge (dtPtr dt'') p dt'') . downRight . left $ dt' else
53                 error "DataTape.left: internal error: went up but no child"
54
55 right :: DataTape -> DataTape
56 right dt@(DataTape m p _) = case cRight (m M.! p) of
57   Just q  -> dt{ dtPtr = q }
58   Nothing -> let dt'@(DataTape m' u _) = up dt
59              in if cDownLeft  (m' M.! u) == Just p then                                        downRight        $ dt' else
60                 if cDownRight (m' M.! u) == Just p then (\dt'' -> merge p (dtPtr dt'') dt'') . downLeft . right $ dt' else
61                 error "DataTape.right: internal error: went up but no child"
62
63 downLeft :: DataTape -> DataTape
64 downLeft dt@(DataTape m p _) = case cDownLeft (m M.! p) of
65   Just q  -> dt{ dtPtr = q }
66   Nothing -> let q = M.size m
67                  c = cell{ cUp = Just p }
68                  n = M.update (\c0 -> Just c0{ cDownLeft = Just q }) p m
69              in maybe id (\r -> merge q r) (cDownRight (m M.! p)) dt{ dtCells = M.insert q c n, dtPtr = q }
70
71 downRight :: DataTape -> DataTape
72 downRight dt@(DataTape m p _) = case cDownRight (m M.! p) of
73   Just q  -> dt{ dtPtr = q }
74   Nothing -> let q = M.size m
75                  c = cell{ cUp = Just p }
76                  n = M.update (\c0 -> Just c0{ cDownRight = Just q }) p m
77              in maybe id (\l -> merge l q) (cDownLeft (m M.! p)) dt{ dtCells = M.insert q c n, dtPtr = q }
78
79 pretty :: DataTape -> String
80 pretty dt = pretty' 3 (5 * 2^(8 - 3 :: Int) + 2) (dtPtr dt) (left . left . left . left . left $ dt)
81
82 pretty' :: Int -> Int -> Int -> DataTape -> String
83 pretty' n dx p0 dt | n >  0 = let dt' = up dt
84                                   isR = cDownRight (dtCells dt' M.! dtPtr dt') == Just (dtPtr dt)
85                                   dx' = dx + (if isR then id else negate) (2 ^ (7 - n)) - 1
86                               in pretty' (n - 1) dx' p0 dt'
87                    | otherwise = let w = 2^(8 :: Int) + 1
88                                  in unlines . (++ [replicate w '+']) . concat . zipWith inflate [5,4 ..] . map (take w) . map (drop dx) . drop 1 . take 8 . pretty'' 7 p0 $ dt
89
90 inflate :: Int -> String -> [String]
91 inflate n l | n >= -1 = let h = map (\c -> if c == '|' then '+' else '-') l
92                             i = map (\c -> if c == '|' then '|' else ' ') l
93                             is = drop 1 (replicate (2^(n+1) `div` 4) i)
94                         in [h] ++ is ++ [l] ++ is
95             | otherwise = error "DataTape.inflate: n < -1"
96
97 pretty'' :: Int -> Int -> DataTape -> [String]
98 pretty'' n p0 dt = (concat . intersperse "|" . map (pretty''' n p0) . iterate right $ dt) : pretty'' (n - 1) p0 (downLeft dt)
99
100 pretty''' :: Int -> Int -> DataTape -> String
101 pretty''' n p0 dt | dtPtr dt == p0 = replicate (2^n-2) ' ' ++ "[" ++ (if get dt then "1" else "0") ++ "]" ++ replicate (2^n-2) ' '
102                   | otherwise      = replicate (2^n-1) ' ' ++        (if get dt then "1" else "0")        ++ replicate (2^n-1) ' '