qc.hs

import Test.QuickCheck
import Text.ParserCombinators.ReadP
import Control.Monad
import Control.Applicative hiding (Const)

data Tree = Leaf Int
          | Branch Tree Tree
          deriving (Show)

treeGen1 :: Gen Tree
treeGen1 =
  oneof [ do n <- arbitrary
             return (Leaf n)
        , do t1 <- arbitrary
             t2 <- arbitrary
             return (Branch t1 t2) ]

treeGen' = oneof [ Leaf <$> arbitrary
                 , Branch <$> arbitrary <*> arbitrary ]

treeGen'' = oneof [ liftM Leaf arbitrary
                  , liftM2 Branch arbitrary arbitrary ]

treeGen2 :: Int -> Gen Tree
treeGen2 0 = do n <- arbitrary
                return (Leaf n)
treeGen2 n = oneof [ fmap Leaf arbitrary
                   , do t1 <- treeGen2 (n-1)
                        t2 <- treeGen2 (n-1)
                        return (Branch t1 t2) ]

instance Arbitrary Tree where
  arbitrary = treeGen2 5

-- a non-empty sequence of letters, digits and underscores (_), that is not one
-- of the reserved words: where, refv, refh, rot, width, or height.

--- Testing file
newtype TestIdent = TestIdent Ident
                  deriving Show

identGen :: Gen Ident
identGen = do
  len <- choose (1, 20)
  identN len
  where charGen = elements $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ ['_']
        identN :: Int -> Gen String
        identN 0 = return []
        identN n | n > 0 = do c <- charGen
                              cs <- identN (n-1)
                              return (c:cs)

instance Arbitrary TestIdent where
  arbitrary = do s <- identGen
                 return (TestIdent s)

parseIdent :: ReadP String
parseIdent = many1 $ satisfy isIdentChar
  where isIdentChar = (`elem` ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ ['_'])

parse = parseIdent <* eof

prop_PPP (TestIdent s) =
  case readP_to_S parse s of
    [(result, "")] -> result == s
    _              -> False

type Program = [Def]
data Def = Def Ident Curve [Def] deriving (Eq, Show)
data Curve = Connect Curve Curve
           | Over Curve Curve
           | Translate Curve Point
           | Scale Curve Expr
           | Refv Curve Expr
           | Refh Curve Expr
           | Rot Curve Expr
           | Single Point
           | Id Ident
           deriving (Eq, Show)
data Point = Point Expr Expr deriving (Eq, Show)
data Expr = Mult Expr Expr
          | Add Expr Expr
          | Width Curve
          | Height Curve
          | Const Number
          deriving (Eq, Show)
type Ident = String
type Number = Double

-- "1*2+3"
--      Mult 1 (Add 2 3)
--      Add (Mult 1 2) 3

newtype TestExprString = TES String
                       deriving Show

numberGen :: Gen String
numberGen = do
  i <- choose (0, 1000 :: Int)
  j <- choose (0, 1000 :: Int)
  return (show i ++ "." ++ show j)

binOpGen :: Gen String
binOpGen = elements [ "+", "*" ]

-- exprStrGen :: Gen String
-- exprStrGen = do
--   i <- numberGen
--   j <- numberGen
--   k <- numberGen
--   op1 <- binOpGen
--   op2 <- binOpGen
--   return (i++op1++j++op2++k)

exprStrGen :: Int -> Gen String
exprStrGen 0 = numberGen
exprStrGen n | n > 0 = do
  op <- binOpGen
  e1 <- exprStrGen (n `div` 2)
  e2 <- exprStrGen (n `div` 2)
  return (e1 ++ op ++ e2)

-- Check for precedence
prop_Precedence s =
  case readP_to_S undefined s of
    [(e, "")] -> checkPrecedences e
  where
    checkPrecedences :: Expr -> Bool
    checkPrecedences (Add e1 e2) = and [ AddP < getPrec e1
                                       , AddP < getPrec e2
                                       , checkPrecedences e1
                                       , checkPrecedences e2 ]
    checkPrecedences (Mult e1 e2) = and [ MultP < getPrec e1
                                        , MultP < getPrec e2
                                        , checkPrecedences e1
                                        , checkPrecedences e2 ]
    checkPrecedences (Const _) = True
    checkPrecedences _ = False

data Prec = AddP | MultP | ConstP deriving (Eq, Ord, Show)

getPrec (Add _ _) = AddP
getPrec (Mult _ _) = MultP
getPrec (Const _) = ConstP


data Direction = GoneLeft | GoneRight | Neither

-- Check for associativity
prop_Assoc s =
  case readP_to_S undefined s of
    [(e, "")] -> checkAssoc e Neither
  where
    checkAssoc (Mult _ _) GoneLeft = False
    checkAssoc (Add _ _) GoneRight = False
    checkAssoc (Mult e1 e2) _ = checkAssoc e1 GoneLeft &&
                                checkAssoc e2 GoneRight
    checkAssoc (Add e1 e2) _ = checkAssoc e1 GoneLeft &&
                               checkAssoc e2 GoneRight
    checkAssoc (Const _) _ = True