{- CSci 450/503: Org. of Programming Languages
   Movable Objects Case Study from Thompson textbook
   H. Conrad Cunningham

1234567890123456789012345678901234567890123456789012345678901234567890

2017-10-28: Adapted from Thompson Sec. 4.6

Adapted from Chapter 14, Section 6, of:
    Simon Thompson.
    Haskell: The Craft of Functional Programming, Third Edition
    Addison-Wesley, 1996-2011.

TODO:
- Factor into separate modules?
- Complete testing module
- Consider class laws for Movable and Named?

-}

module MovableObjects
  ( Movable(..)  -- export class and all methods
  , Named(..)
  , Vector(..)   -- export data type and all constructors
  , Point(..)
  , Figure(..)
  , Name(..)
  , mapName      -- export function
  )
where

{- MOVABLE OBJECTS -}

-- Displacement in 2-space
data Vector = Vector Float Float
              deriving Show

-- Point object in 2-space
data Point  = Point Float Float 
              deriving Show

-- Figure object in 2-space
data Figure = Line Point Point 
            | Circle Point Float -- center, radius
              deriving Show

-- Type class for objects movable in 2-space
class Movable a where
    move      :: Vector -> a -> a
    reflectX  :: a -> a             -- reflect on x-axis
    reflectY  :: a -> a             -- relfect on y-axis
    rotate180 :: a -> a             -- relflect on both axes
    rotate180 = reflectX . reflectY -- default definition

-- Make Point Movable
instance Movable Point where
    move (Vector v1 v2) (Point c1 c2) = Point (c1+v1) (c2+v2)
    reflectX (Point c1 c2)  = Point c1 (-c2)
    reflectY (Point c1 c2)  = Point (-c1) c2
    rotate180 (Point c1 c2) = Point (-c1) (-c2) -- override

-- Make Figure Movable
instance Movable Figure where
    move v (Line p1 p2) = Line (move v p1) (move v p2)
    move v (Circle p r) = Circle (move v p) r

    reflectX (Line p1 p2) = Line (reflectX p1) (reflectX p2)
    reflectX (Circle p r) = Circle (reflectX p) r

    reflectY (Line p1 p2) = Line (reflectY p1) (reflectY p2)
    reflectY (Circle p r) = Circle (reflectY p) r

    -- reflect180 for Figure uses default

-- Make lists of Movable object Movable
instance Movable a => Movable [a] where
    move v   = map (move v)
    reflectX = map reflectX
    reflectY = map reflectY
    -- reflect180 for list uses default
 

{- NAMED OBJECTS -}

-- Type class for named objects
class Named a where
    lookName :: a -> String
    giveName :: String -> a -> a

-- Name data type to attach a name to an object
data Name a = Pair a String

-- Make Name instance of Named
instance Named (Name a) where
    lookName (Pair obj nm)   = nm
    giveName nm (Pair obj _) = (Pair obj nm)


{- COMBINING CLASSES -}

-- Can we add names to Movable objects?

-- Function "mapName" **lifts** an operation to work over
-- "named" objects
mapName :: (a -> b) -> Name a -> Name b
mapName f (Pair obj nm) = Pair (f obj) nm


-- All operations on the Movable class can be lifted
-- Make Name an instance of Movable if its wrapped object is
instance Movable a => Movable (Name a) where
    move v   = mapName (move v)
    reflectX = mapName reflectX
    reflectY = mapName reflectY
    -- reflect180 uses default

-- Define type class NamedMovable that combines two 
class (Movable b, Named b) => NamedMovable b

instance Movable a => NamedMovable (Name a)

-- Type class NamedMovable thus reuses code for Movable