-----------------------------------------------------------------------
--
--  Haskell: The Craft of Functional Programming
--  Simon Thompson
--  (c) Addison-Wesley, 1996-2011.
--
--  Pic.hs
-- 
--      A deep embedding of pictures
--
-----------------------------------------------------------------------

module Pic where

import Pictures

-- Data type representing pictures

data Pic = Horse |
           Above Pic Pic |
           Beside Pic Pic |
           FlipH Pic |
           FlipV Pic 

-- Interpreting a Pic as a Picture

interpretPic :: Pic -> Picture

interpretPic :: Pic -> Picture
interpretPic Pic
Horse = Picture
horse
interpretPic (Above Pic
pic1 Pic
pic2)
  = Picture -> Picture -> Picture
above (Pic -> Picture
interpretPic Pic
pic1)  (Pic -> Picture
interpretPic Pic
pic2)
interpretPic (Beside Pic
pic1 Pic
pic2)
  = Picture -> Picture -> Picture
beside (Pic -> Picture
interpretPic Pic
pic1)  (Pic -> Picture
interpretPic Pic
pic2)
interpretPic (FlipH Pic
pic)
  = Picture -> Picture
flipH (Pic -> Picture
interpretPic Pic
pic)
interpretPic (FlipV Pic
pic)
  = Picture -> Picture
flipV (Pic -> Picture
interpretPic Pic
pic)

-- Tidying up a picture ...

-- remove pairs of flips
-- push flips through placement above / beside

tidyPic :: Pic -> Pic

tidyPic :: Pic -> Pic
tidyPic (FlipV (FlipV Pic
pic)) 
  = Pic -> Pic
tidyPic Pic
pic
tidyPic (FlipV (FlipH Pic
pic)) 
  = Pic -> Pic
FlipH (Pic -> Pic
tidyPic (Pic -> Pic
FlipV Pic
pic)) 

tidyPic (FlipV (Above Pic
pic1 Pic
pic2))
  = Pic -> Pic -> Pic
Above (Pic -> Pic
tidyPic (Pic -> Pic
FlipV Pic
pic1)) (Pic -> Pic
tidyPic (Pic -> Pic
FlipV Pic
pic2)) 
tidyPic (FlipV (Beside Pic
pic1 Pic
pic2))
  = Pic -> Pic -> Pic
Beside (Pic -> Pic
tidyPic (Pic -> Pic
FlipV Pic
pic2)) (Pic -> Pic
tidyPic (Pic -> Pic
FlipV Pic
pic1)) 

tidyPic (FlipH (FlipH Pic
pic)) 
  = Pic -> Pic
tidyPic Pic
pic
  
tidyPic (FlipH (Above Pic
pic1 Pic
pic2))
  = Pic -> Pic -> Pic
Above (Pic -> Pic
tidyPic (Pic -> Pic
FlipH Pic
pic2)) (Pic -> Pic
tidyPic (Pic -> Pic
FlipH Pic
pic1)) 
tidyPic (FlipH (Beside Pic
pic1 Pic
pic2))
  = Pic -> Pic -> Pic
Beside (Pic -> Pic
tidyPic (Pic -> Pic
FlipH Pic
pic1)) (Pic -> Pic
tidyPic (Pic -> Pic
FlipH Pic
pic2))