module Language.Piet.Interpreter
(
interpret
, interpretWhite
, nonBlackSucc
, succCoordinates
, colours2Command
, colourDiff2Command
) where
import Control.Monad
import Data.IntMap hiding (filter)
import Data.Maybe
import Language.Piet.Commands
import Language.Piet.PietMonad
import Language.Piet.Types
interpret :: Program -> PietMonad ()
interpret = interpret' Nothing
interpret' :: Maybe (Lightness, HueColour, Int)
-> Program
-> PietMonad ()
interpret' previous program = do
(x, y) <- getPosition
case imgPixel x y (image program) of
Hue l c -> do
maybe (return ())
(\(oldL, oldC, oldS) -> colours2Command oldL oldC l c oldS)
previous
dp <- getDP
cc <- getCC
let key = imgPixel x y (mask program)
let label = findWithDefault EmptyInfo key (info program)
case nonBlackSucc program label dp cc of
Just (x', y', dp', cc') -> do
setPosition x' y'
setDP dp'
setCC cc'
interpret' (Just (l, c, labelSize label)) program
Nothing -> do
terminate
White -> interpretWhite program
Black -> do
logMessage Fatal "Entered black block, terminate"
terminate
interpretWhite :: Program -> PietMonad ()
interpretWhite program = do
(x, y) <- getPosition
let key = imgPixel x y (mask program)
let codels = labelSize $ findWithDefault EmptyInfo key (info program)
when (White == imgPixel x y (image program))
$ interpretWhite' (8 * codels) program
interpretWhite' :: Int -> Program -> PietMonad ()
interpretWhite' limit program
| limit <= 0 = terminate
| otherwise = do
(x, y) <- getPosition
case imgPixel x y (image program) of
White -> do
dp <- getDP
let (x', y') = addCoordinates dp x y
if isBlocked x' y' program
then do
cc <- getCC
setDP $ rotate 1 dp
setCC $ toggle 1 cc
interpretWhite' (limit 1) program
else do
setPosition x' y'
interpretWhite' (limit 1) program
_ -> interpret' Nothing program
nonBlackSucc :: Program
-> LabelInfo
-> DirectionPointer
-> CodelChooser
-> Maybe (Int, Int, DirectionPointer, CodelChooser)
nonBlackSucc program label dp cc = let
directions = fmap (\(r, t) -> (rotate r dp, toggle t cc))
$ zip [ 0, 0, 1, 1, 2, 2, 3, 3 ] (0 : cycle [ 1, 1, 0, 0 ])
in
fmap (\((x, y), (d, c)) -> (x, y, d, c)) $ listToMaybe
$ filter (\((x, y), _) -> not (isBlocked x y program))
$ zip (fmap (uncurry (succCoordinates label)) directions) directions
succCoordinates :: LabelInfo
-> DirectionPointer
-> CodelChooser
-> (Int, Int)
succCoordinates label dp cc = let
(getX, getY) = case (dp, cc) of
(DPRight, CCLeft) -> (borderCoord . labelRight, borderMin . labelRight)
(DPRight, CCRight) -> (borderCoord . labelRight, borderMax . labelRight)
(DPDown, CCLeft) -> (borderMax . labelBottom, borderCoord . labelBottom)
(DPDown, CCRight) -> (borderMin . labelBottom, borderCoord . labelBottom)
(DPLeft, CCLeft) -> (borderCoord . labelLeft, borderMax . labelLeft)
(DPLeft, CCRight) -> (borderCoord . labelLeft, borderMin . labelLeft)
(DPUp, CCLeft) -> (borderMin . labelTop, borderCoord . labelTop)
(DPUp, CCRight) -> (borderMax . labelTop, borderCoord . labelTop)
in
addCoordinates dp (getX label) (getY label)
colours2Command :: Lightness
-> HueColour
-> Lightness
-> HueColour
-> Int
-> PietMonad ()
colours2Command fromLight fromColour toLight toColour = colourDiff2Command
(lightnessChange fromLight toLight) (hueChange fromColour toColour)
colourDiff2Command :: Lightness -> HueColour -> Int -> PietMonad ()
colourDiff2Command Light Red _ = return ()
colourDiff2Command Normal Red n = piet_push n
colourDiff2Command Dark Red _ = piet_pop
colourDiff2Command Light Yellow _ = piet_add
colourDiff2Command Normal Yellow _ = piet_subtract
colourDiff2Command Dark Yellow _ = piet_multiply
colourDiff2Command Light Green _ = piet_divide
colourDiff2Command Normal Green _ = piet_mod
colourDiff2Command Dark Green _ = piet_not
colourDiff2Command Light Cyan _ = piet_greater
colourDiff2Command Normal Cyan _ = piet_pointer
colourDiff2Command Dark Cyan _ = piet_switch
colourDiff2Command Light Blue _ = piet_duplicate
colourDiff2Command Normal Blue _ = piet_roll
colourDiff2Command Dark Blue _ = piet_in_number
colourDiff2Command Light Magenta _ = piet_in_char
colourDiff2Command Normal Magenta _ = piet_out_number
colourDiff2Command Dark Magenta _ = piet_out_char