Morphisms.hs

-- | Tests for morphisms

module TestSuite.Morphisms where

--------------------------------------------------------------------------------

import Test.Tasty
import Test.Tasty.QuickCheck
import Test.QuickCheck

import Control.Applicative
import Control.Monad hiding ( mapM , mapM_ , forM , forM_ )
import Data.List ( sort , intercalate )
import Data.Char ( ord )
import Data.Foldable
import Data.Traversable
import Prelude hiding (foldl,foldr,mapM,mapM_,concat,concatMap)

import Data.Generics.Fixplate.Base
-- import Data.Generics.Fixplate.Misc
-- import Data.Generics.Fixplate.Attributes
import Data.Generics.Fixplate.Morphisms
-- import Data.Generics.Fixplate.Traversals

import TestSuite.Tools
import TestSuite.Misc

--------------------------------------------------------------------------------

testgroup_Morphisms :: TestTree
testgroup_Morphisms = testGroup "Morphisms"
  [ testProperty "para"                prop_para
  , testProperty "paraList"            prop_paraList
  , testProperty "cataHisto"           prop_cataHisto
  , testProperty "paraHisto"           prop_paraHisto
  ]

--------------------------------------------------------------------------------
-- Tests

{-
runtests_Morphisms :: IO ()
runtests_Morphisms = do
  quickCheck prop_para
  quickCheck prop_paraList
  quickCheck prop_cataHisto
  quickCheck prop_paraHisto
  -- quickCheck prop_zygo      -- moved to Attributes.hs, to avoid circular imports
  -- quickCheck prop_zygo_
-}
 
prop_para :: FixT Label -> Bool
prop_para tree = para f tree == para' f' tree where
  f' :: FixT Label -> TreeF Label Integer -> Integer
  f' t@(Fix (TreeF (Label label) sub)) js = h label (toList sub) (toList js)

  f :: TreeF Label (FixT Label, Integer) -> Integer
  f t@(TreeF (Label label) subjs) = h label sub js where
    (sub,js) = unzip $ toList t

  h :: String -> [FixT Label] -> [Integer] -> Integer
  h label ts js = Prelude.sum $ zipWith (*) [3..] (map (fi.ord) label ++ map g ts ++ js)
  g (Fix (TreeF (Label label) _)) = (Prelude.sum (map (fi.ord) label)) `mod` 59

  fi = fromIntegral :: Int -> Integer

prop_paraList :: FixT Label -> Bool
prop_paraList tree = para' f tree == paraList flist tree where
  f t s = flist t (toList s)
  flist :: FixT Label -> [Integer] -> Integer
  flist t@(Fix (TreeF (Label label) sub)) js = Prelude.sum $ zipWith (*) [4..] (map (fi.ord) label ++ js)

  fi = fromIntegral :: Int -> Integer

prop_cataHisto :: FixT Label -> Bool
prop_cataHisto tree = (cata f tree == histo (f . fmap attribute) tree) where

  f :: TreeF Label String -> String
  f t@(TreeF (Label label) child) = "<" ++ label ++ ">[" ++ intercalate "," child ++ "]"

prop_paraHisto :: FixT Label -> Bool
prop_paraHisto tree = (para f tree == histo (f . fmap (\t -> (forget t, attribute t))) tree) where
   
  f :: TreeF Label (FixT Label, Integer) -> Integer
  f t@(TreeF (Label label) subjs) = h label sub js where
    (sub,js) = unzip $ toList t

  h :: String -> [FixT Label] -> [Integer] -> Integer
  h label ts js = Prelude.sum $ zipWith (*) [3..] (map (fi.ord) label ++ map g ts ++ js)
  g (Fix (TreeF (Label label) _)) = (Prelude.sum (map (fi.ord) label)) `mod` 59

  fi = fromIntegral :: Int -> Integer

--------------------------------------------------------------------------------