never executed always true always false
1 module HelVM.HelMA.Automata.Piet.Automaton (
2 interpret,
3 nonBlackSucc,
4 succCoordinates,
5 colors2Command,
6 colorDiff2Command,
7 ) where
8
9 import HelVM.HelMA.Automata.Piet.Types.Memory
10
11 import HelVM.HelMA.Automata.Piet.Combiner.ALU
12 import HelVM.HelMA.Automata.Piet.Combiner.CPU
13
14
15 import HelVM.HelMA.Automata.Piet.Types.Brightness
16 import HelVM.HelMA.Automata.Piet.Types.ChromaticColor
17 import HelVM.HelMA.Automata.Piet.Types.CodelChooser
18 import HelVM.HelMA.Automata.Piet.Types.Color
19 import HelVM.HelMA.Automata.Piet.Types.Coordinates
20 import HelVM.HelMA.Automata.Piet.Types.DirectionPointer
21 import HelVM.HelMA.Automata.Piet.Types.Hue
22 import HelVM.HelMA.Automata.Piet.Types.Image
23 import HelVM.HelMA.Automata.Piet.Types.InstructionCounter
24 import HelVM.HelMA.Automata.Piet.Types.Label
25 import HelVM.HelMA.Automata.Piet.Types.Orientation
26 import HelVM.HelMA.Automata.Piet.Types.Program
27
28 import HelVM.HelMA.Automaton.Eff.MonadEff
29 import HelVM.HelMA.Automaton.Trampoline as Trampoline
30
31 import HelVM.HelIO.Control.Safe
32
33 import Data.IntMap hiding (filter)
34
35 -- Main interpreter entry point
36
37 interpret :: AppEff m => Program -> m ()
38 interpret prog = Trampoline.trampolineM interpretStep initialState where
39 initialState = (NormalStep Nothing, initialMemory prog)
40
41 interpretStep :: AppEff m => (StepState, Memory) -> m (Either () InterpreterMemory)
42 interpretStep (NormalStep prev, mem) = stepNormal prev mem
43 interpretStep (WhiteStep limit, mem) = pure $ stepWhite limit mem
44
45 -- Step handlers
46
47 stepNormal :: AppEff m => Maybe PreviousColor -> Memory -> m (Either () InterpreterMemory)
48 stepNormal previous memory = evalPixel (currentPixel memory) previous memory
49
50 stepWhite :: Int -> Memory -> Either () InterpreterMemory
51 stepWhite limit memory
52 | limit <= 0 = Trampoline.break ()
53 | otherwise = Trampoline.continue $ checkWhitePixel (currentPixel memory) limit memory
54
55 -- Pixel handlers
56
57 evalPixel :: AppEff m => Color -> Maybe PreviousColor -> Memory -> m (Either () InterpreterMemory)
58 evalPixel (Chromatic color) previous mem = evalChromaticPixel previous color mem
59 evalPixel White _ mem = pure $ Trampoline.continue $ evalWhitePixel mem
60 evalPixel Black _ _ = liftError "Entered black block, terminate"
61
62 evalChromaticPixel :: AppEff m => Maybe PreviousColor -> ChromaticColor -> Memory -> m (Either () InterpreterMemory)
63 evalChromaticPixel previous color mem = makeNext <$> applyPreviousColor previous color mem where
64 makeNext mem1 = handleNext (nonBlackSucc (programMemory mem1) mStats (orientationMemory mem1)) (color, labelSize mStats) mem1
65 mStats = getMaskInfo (programMemory mem) (positionMemory mem)
66
67 evalWhitePixel :: Memory -> InterpreterMemory
68 evalWhitePixel mem = (WhiteStep whiteLimit, mem) where
69 whiteLimit = 8 * labelSize (getMaskInfo (programMemory mem) (positionMemory mem))
70
71 checkWhitePixel :: Color -> Int -> Memory -> InterpreterMemory
72 checkWhitePixel White limit = checkWhitePixelStep limit
73 checkWhitePixel _ _ = (NormalStep Nothing, )
74
75 checkWhitePixelStep :: Int -> Memory -> InterpreterMemory
76 checkWhitePixelStep limit mem = (WhiteStep (limit - 1), stepWhitePixel mem)
77
78 -- Helper functions
79
80 currentPixel :: Memory -> Color
81 currentPixel mem = pixelImage (positionMemory mem) (image $ programMemory mem)
82
83 applyPreviousColor :: AppEff m => Maybe PreviousColor -> ChromaticColor -> Memory -> m Memory
84 applyPreviousColor (Just (oldColor, oldS)) color = colors2Command oldColor color oldS
85 applyPreviousColor Nothing _ = pure
86
87 getMaskInfo :: Program -> Coordinates -> Maybe LabelInfo
88 getMaskInfo program pos = findWithDefault Nothing (pixelImage pos (mask program)) (info program)
89
90 handleNext :: Maybe InstructionCounter -> PreviousColor -> Memory -> Either () InterpreterMemory
91 handleNext (Just ic) prevColor mem = Trampoline.continue $ handleNextSuccess ic prevColor mem
92 handleNext Nothing _ _ = Trampoline.break ()
93
94 handleNextSuccess :: InstructionCounter -> PreviousColor -> Memory -> InterpreterMemory
95 handleNextSuccess ic prevColor mem =
96 ( NormalStep (Just prevColor)
97 , setInstructionCounter ic mem
98 )
99
100 -- Utilities
101
102 nonBlackSucc :: Program -> Maybe LabelInfo -> Orientation -> Maybe InstructionCounter
103 nonBlackSucc program mStats reg = uncurry InstructionCounter <$> find isValid (zip (fmap (succCoordinates mStats) directions) directions) where
104 directions = flip rotateToggle reg <$> zip [ 0, 0, 1, 1, 2, 2, 3, 3 ] (0 : cycle [ 1, 1, 0, 0 ])
105 isValid (pos, _) = not (isBlocked pos program)
106
107 succCoordinates :: Maybe LabelInfo -> Orientation -> Coordinates
108 succCoordinates labelInfo reg = addCoordinates (directionPointer reg) $ toCooCoordinates labelInfo reg
109
110 toCooCoordinates :: Maybe LabelInfo -> Orientation -> Coordinates
111 toCooCoordinates (Just labelInfo) reg = (getX reg labelInfo, getY reg labelInfo)
112 toCooCoordinates Nothing _ = (0, 0)
113
114 getX :: Orientation -> LabelInfo -> Int
115 getX (Orientation DPRight CCLeft) = borderCoord . labelRight
116 getX (Orientation DPRight CCRight) = borderCoord . labelRight
117 getX (Orientation DPDown CCLeft) = borderMax . labelBottom
118 getX (Orientation DPDown CCRight) = borderMin . labelBottom
119 getX (Orientation DPLeft CCLeft) = borderCoord . labelLeft
120 getX (Orientation DPLeft CCRight) = borderCoord . labelLeft
121 getX (Orientation DPUp CCLeft) = borderMin . labelTop
122 getX (Orientation DPUp CCRight) = borderMax . labelTop
123
124 getY :: Orientation -> LabelInfo -> Int
125 getY (Orientation DPRight CCLeft) = borderMin . labelRight
126 getY (Orientation DPRight CCRight) = borderMax . labelRight
127 getY (Orientation DPDown CCLeft) = borderCoord . labelBottom
128 getY (Orientation DPDown CCRight) = borderCoord . labelBottom
129 getY (Orientation DPLeft CCLeft) = borderMax . labelLeft
130 getY (Orientation DPLeft CCRight) = borderMin . labelLeft
131 getY (Orientation DPUp CCLeft) = borderCoord . labelTop
132 getY (Orientation DPUp CCRight) = borderCoord . labelTop
133
134 colors2Command :: AppEff m => ChromaticColor -> ChromaticColor -> Int -> Memory -> m Memory
135 colors2Command from to = colorDiff2Command $ diffColor from to
136
137 colorDiff2Command :: AppEff m => ChromaticColor -> Int -> Memory -> m Memory
138 colorDiff2Command (ChromaticColor Light Red) _ s = pure s
139 colorDiff2Command (ChromaticColor Normal Red) n s = pietPush n s
140 colorDiff2Command (ChromaticColor Dark Red) _ s = pietPop s
141 colorDiff2Command (ChromaticColor Light Yellow) _ s = pietAdd s
142 colorDiff2Command (ChromaticColor Normal Yellow) _ s = pietSubtract s
143 colorDiff2Command (ChromaticColor Dark Yellow) _ s = pietMultiply s
144 colorDiff2Command (ChromaticColor Light Green) _ s = pietDivide s
145 colorDiff2Command (ChromaticColor Normal Green) _ s = pietMod s
146 colorDiff2Command (ChromaticColor Dark Green) _ s = pietNot s
147 colorDiff2Command (ChromaticColor Light Cyan) _ s = pietGreater s
148 colorDiff2Command (ChromaticColor Normal Cyan) _ s = pietPointer s
149 colorDiff2Command (ChromaticColor Dark Cyan) _ s = pietSwitch s
150 colorDiff2Command (ChromaticColor Light Blue) _ s = pietDuplicate s
151 colorDiff2Command (ChromaticColor Normal Blue) _ s = pietRoll s
152 colorDiff2Command (ChromaticColor Dark Blue) _ s = pietInNumber s
153 colorDiff2Command (ChromaticColor Light Magenta) _ s = pietInChar s
154 colorDiff2Command (ChromaticColor Normal Magenta) _ s = pietOutNumber s
155 colorDiff2Command (ChromaticColor Dark Magenta) _ s = pietOutChar s
156
157 type PreviousColor = (ChromaticColor, Int)
158
159 data StepState
160 = NormalStep (Maybe PreviousColor)
161 | WhiteStep Int
162
163 type InterpreterMemory = (StepState, Memory)