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