-- D. Sannella. M Fourman, H. Peng and P. Wadler
-- Introduction to Computation: Haskell, Logic and Automata
-- Undergraduate Topics in Computer Science, Springer (2021)
-- ISBN 978-3-030-76907

-- Chapter 15 : Algebraic Data Types

module Chap15_algebraic_data_types where

import Test.QuickCheck (Arbitrary, arbitrary, sized, oneof)
import Control.Monad (liftM2)

-- Booleans

-- The following type definition is commented out because it is already in the Prelude.
-- You can hide that definition to allow it to be re-defined by putting the following at the top of this module:
-- import Prelude hiding (Bool, True, False)

-- data Bool = False | True

eqBool :: Bool -> Bool -> Bool
eqBool False False = True
eqBool True  True  = True
eqBool _     _     = False

showBool :: Bool -> String
showBool False = "False"
showBool True  = "True"

-- Seasons

data Season = Winter | Spring | Summer | Fall

next :: Season -> Season
next Winter = Spring
next Spring = Summer
next Summer = Fall
next Fall   = Winter

eqSeason :: Season -> Season -> Bool
eqSeason Winter Winter = True
eqSeason Spring Spring = True
eqSeason Summer Summer = True
eqSeason Fall   Fall   = True
eqSeason _      _      = False

showSeason :: Season -> String
showSeason Winter = "Winter"
showSeason Spring = "Spring"
showSeason Summer = "Summer"
showSeason Fall   = "Fall"

data Season' = Winter' | Spring' | Summer' | Fall' deriving (Eq,Show)

toInt :: Season -> Int
toInt Winter = 0
toInt Spring = 1
toInt Summer = 2
toInt Fall   = 3

fromInt :: Int -> Season
fromInt 0 = Winter
fromInt 1 = Spring
fromInt 2 = Summer
fromInt 3 = Fall

next' :: Season -> Season
next' x = fromInt ((toInt x + 1) `mod` 4)

eqSeason' :: Season -> Season -> Bool
eqSeason' x y = (toInt x == toInt y)

-- Shapes

type Radius = Float
type Width  = Float
type Height = Float

data Shape = Circle Radius
           | Rect Width Height
  deriving (Eq,Show)

area :: Shape -> Float
area (Circle r) = pi * r^2
area (Rect w h) = w * h

eqShape :: Shape -> Shape -> Bool
eqShape (Circle r) (Circle r')  = (r == r')
eqShape (Rect w h) (Rect w' h') = (w == w') && (h == h')
eqShape _          _            = False

showShape :: Shape -> String
showShape (Circle r) = "Circle " ++ showF r
showShape (Rect w h) = "Rect " ++ showF w ++ " " ++ showF h

showF :: Float -> String
showF x | x >= 0    = show x
        | otherwise = "(" ++ show x ++ ")"

isCircle :: Shape -> Bool
isCircle (Circle r) = True
isCircle (Rect w h) = False

isRect :: Shape -> Bool
isRect (Circle r) = False
isRect (Rect w h) = True

radius :: Shape -> Float
radius (Circle r) = r

width :: Shape -> Float
width (Rect w h) = w

height :: Shape -> Float
height (Rect w h) = h

area' :: Shape -> Float
area' s =
  if isCircle s then
    let
      r = radius s
    in
      pi * r^2
  else if isRect s then
    let
      w = width s
      h = height s
    in
      w * h
  else error "impossible"

-- Tuples

data Pair a b = Pair a b deriving (Eq,Show)

data Pair' a b = MkPair a b deriving (Eq,Show)

eqPair :: (Eq a, Eq b) => Pair a b -> Pair a b -> Bool
eqPair (Pair x y) (Pair x' y') = x == x' && y == y'

showPair :: (Show a, Show b) => Pair a b -> String
showPair (Pair x y) = "Pair " ++ show x ++ " " ++ show y

data Triple a b c = Triple a b c deriving (Eq,Show)

-- Lists

data List a = Nil
            | Cons a (List a)
  deriving (Eq,Show)

append :: List a -> List a -> List a
append Nil ys         = ys
append (Cons x xs) ys = Cons x (append xs ys)

-- Optional values

-- The following type definition is commented out because it is already in the Prelude.
-- You can hide that definition to allow it to be re-defined by putting the following at the top of this module:
-- import Prelude hiding (Maybe, Nothing, Just)

-- data Maybe a = Nothing | Just a
--   deriving (Eq,Show)

myDiv :: Int -> Int -> Maybe Int
myDiv n 0 = Nothing
myDiv n m = Just (n `div` m)

i1 = 3 `myDiv` 0

i2 = 6 `myDiv` 2

-- The following function definition is commented out because it is already in the Prelude.
-- You can hide that definition to allow it to be re-defined by putting the following at the top of this module:
-- import Prelude hiding (lookup)

-- lookup :: Eq a => a -> [(a,b)] -> Maybe b
-- lookup key []                      = Nothing
-- lookup key ((x,y):xys) | key == x  = Just y
--                        | otherwise = lookup key xys

power :: Maybe Int -> Int -> Int
power Nothing n  = 2 ^ n
power (Just m) n = m ^ n

i3 = power Nothing 3

i4 = power (Just 3) 3

right :: Int -> Int -> Int
right n m = case n `myDiv` m of
              Nothing -> 3
              Just r  -> r + 3

-- Disjoint union of two types

-- The following type definition is commented out because it is already in the Prelude.
-- You can hide that definition to allow it to be re-defined by putting the following at the top of this module:
-- import Prelude hiding (Either, Left, Right)

-- data Either a b = Left a | Right b
--   deriving (Eq,Show)

mylist :: [Either Int String]
mylist = [Left 4, Left 1, Right "hello", Left 2,
          Right " ", Right "world", Left 17]

addints :: [Either Int String] -> Int
addints xs = sum [ n | Left n <- xs ]

addstrs :: [Either Int String] -> String
addstrs xs = concat [ s | Right s <- xs ]

l1 = addints mylist

l2 = addstrs mylist

-- Exercise 1

data Fruit = Apple String Bool
           | Orange String Int
  deriving (Eq,Show)

-- Exercise 3

data Widelist a = Nil'
                | Cons' a (Widelist a)
                | Append (Widelist a) (Widelist a)
  deriving (Eq,Show)

instance Arbitrary a => Arbitrary (Widelist a) where
  arbitrary = sized list
    where
      list n | n<=0 = return Nil'
             | otherwise
                    = oneof [liftM2 Cons' arbitrary sublist,
                             liftM2 Append sublist sublist]
        where sublist = list (n `div` 2)

-- Exercise 6

type Password = String
type Locked a = Password -> Maybe a