<commit_before>{-# LANGUAGE GADTs, TypeFamilies #-}
{-# OPTIONS -W #-}

module Language.Hakaru.Symbolic where

data Prob
data Measure a
data Dist a

-- Symbolic AST (from Syntax.hs)
class Symbolic repr where
  real 			    :: Double -> repr Double
  bool 			    :: Bool -> repr Bool
  add, minus, mul, exp  	:: repr Double -> repr Double -> repr Double
  sqrt, cos, sin	:: repr Double -> repr Double
  bind	 		    :: repr (Measure a) -> (repr a -> repr (Measure a)) 
	   		           -> repr (Measure a)
  ret 			    :: repr a -> repr (Measure a)
  uniformD, uniform, normal :: repr Double -> repr Double -> repr (Dist Double)
  conditioned, unconditioned :: repr (Dist a) -> repr (Measure a)

-- Printer (to Maple)
type VarCounter = Int
newtype Maple a = Maple { unMaple :: Bool -> VarCounter -> String }

instance Symbolic Maple where
  real x 	= Maple $ \_ _ -> show x
  bool x 	= Maple $ \_ _ -> show x
  add e1 e2 	= Maple $ \f h -> unMaple e1 f h ++ "+" ++ unMaple e2 f h
  minus e1 e2 	= Maple $ \f h -> unMaple e1 f h ++ "-" ++ unMaple e2 f h  
  mul e1 e2 	= Maple $ \f h -> unMaple e1 f h ++ "*" ++ unMaple e2 f h
  exp e1 e2     = Maple $ \f h -> unMaple e1 f h ++ "^" ++ unMaple e2 f h
  sqrt e	= Maple $ \f h -> "sqrt(" ++ unMaple e f h ++ ")"
  cos e		= Maple $ \f h -> "cos(" ++ unMaple e f h ++ ")"
  sin e		= Maple $ \f h -> "sin(" ++ unMaple e f h ++ ")"
  bind m c 	= Maple $ \f h -> unMaple m True h ++ 
  		          unMaple (c (Maple $ \_ _ -> ("x" ++ show h))) (f) (succ h)
  		          ++ unMaple m False h 
  uniform e1 e2  = Maple $ \f h -> if f == True then  
		          show (1/((read (unMaple e2 f h) :: Double) - 
		          (read (unMaple e1 f h) :: Double))) ++ " * Int (" 
		          else ", x" ++ show h ++ "=" ++ unMaple e1 f h ++ ".." ++ 
		          unMaple e2 f h ++ ")"
  uniformD e1 e2 = Maple $ \f h -> if f == True then  
		          show (1/((read (unMaple e2 f h) :: Double) - 
		          (read (unMaple e1 f h) :: Double))) ++ " * Sum (" 
		          else ", x" ++ show h ++ "=" ++ unMaple e1 f h ++ ".." ++ 
		          unMaple e2 f h ++ ")"				  
  normal e1 e2 	= Maple $ \f h -> if f == True then  
		          "Int (PDF (Normal (" ++ unMaple e1 f h ++ ", " ++
		          unMaple e2 f h ++ ", x" ++ show h ++ ") * "  
		          else ", x" ++ show h ++ "=" ++ unMaple e1 f h ++ ".." ++ 
		          unMaple e2 f h ++ ")"			  
  unconditioned e = Maple $ \f h -> unMaple e f h
  conditioned e   = Maple $ \f h -> unMaple e f h  
  ret e 	      = Maple $ \f h -> "g(" ++ unMaple e f h ++ ")"

view e = unMaple e True 0

-- TEST CASES
exp1 = unconditioned (uniform (real 1) (real 3)) `bind` \s ->
       ret s

-- Borel's Paradox Simplified
exp2 = unconditioned (uniformD (real 1) (real 3)) `bind` \s ->
       unconditioned (uniform  (real (-1)) (real 1)) `bind` \x ->
       let y = s `mul` x in ret y

-- Borel's Paradox
exp3 = unconditioned (uniformD (real 1) (real 2)) `bind` \s ->
       unconditioned (uniform  (real (-1)) (real 1)) `bind` \x ->
       let y = (Language.Hakaru.Symbolic.sqrt ((real 1 ) `minus` 
			   (Language.Hakaru.Symbolic.exp s (real 2)))) `mul`
	           (Language.Hakaru.Symbolic.sin x) in ret y  

test = view exp1
test2 = view exp2
test3 = view exp3<commit_msg>split class into smaller, semantically more meaningful classes.  add some Applicative-related kit to make the instances much cleaner<commit_after>{-# LANGUAGE GADTs, TypeFamilies #-}
{-# OPTIONS -Wall #-}

module Language.Hakaru.Symbolic where

data Prob
data Measure a
data Dist a

-- Symbolic AST (from Syntax.hs)
class RealComp repr where
  real                 :: Double -> repr Double
  add, minus, mul, exp :: repr Double -> repr Double -> repr Double
  sqrt, cos, sin       :: repr Double -> repr Double

class BoolComp repr where
  bool                 :: Bool -> repr Bool

class MeasMonad repr where
  bind                 :: repr (Measure a) -> (repr a -> repr (Measure a)) 
                          -> repr (Measure a)
  ret                  :: repr a -> repr (Measure a)

class Distrib repr where
  uniformD, uniform, normal :: repr Double -> repr Double -> repr (Dist Double)

class Conditioning repr where
  conditioned, unconditioned :: repr (Dist a) -> repr (Measure a)

-- Printer (to Maple)
type VarCounter = Int
newtype Maple a = Maple { unMaple :: Bool -> VarCounter -> String }

-- if it weren't for the constraints, we could/should use Applicative
pure :: Show a => a -> Maple a
pure x = Maple $ \_ _ -> show x

liftA1 :: (String -> String) -> Maple a -> Maple a
liftA1 pr x = Maple $ \f h -> pr (unMaple x f h)

liftA2 :: (String -> String -> String) -> Maple a -> Maple a -> Maple a
liftA2 pr e1 e2 = Maple $ \f h -> pr (unMaple e1 f h) (unMaple e2 f h)

-- variant for ret
liftA1M :: (String -> String) -> Maple a -> Maple (Measure a)
liftA1M pr x = Maple $ \f h -> pr (unMaple x f h)

mkPr :: String -> (String -> String)
mkPr s t = s ++ "(" ++ t ++ ")"

d2m :: Maple (Dist a) -> Maple (Measure a)
d2m e = Maple $ unMaple e

infixPr :: String -> (String -> String -> String)
infixPr s a b = a ++ s ++ b

instance RealComp Maple where
  real  = pure
  add   = liftA2 $ infixPr "+"
  minus = liftA2 $ infixPr "-"
  mul   = liftA2 $ infixPr "*"
  exp   = liftA2 $ infixPr "^"
  sqrt  = liftA1 $ mkPr "sqrt"
  cos   = liftA1 $ mkPr "cos"
  sin   = liftA1 $ mkPr "sin"

instance BoolComp Maple where
  bool  = pure

instance MeasMonad Maple where
  ret      = liftA1M $ mkPr "g"
  bind m c = Maple $ \f h -> unMaple m True h ++ 
                    unMaple (c (Maple $ \_ _ -> ("x" ++ show h))) (f) (succ h)
                    ++ unMaple m False h 

instance Distrib Maple where
  uniform e1 e2  = Maple $ \f h -> if f == True then  
                  show (1/((read (unMaple e2 f h) :: Double) - 
                  (read (unMaple e1 f h) :: Double))) ++ " * Int (" 
                  else ", x" ++ show h ++ "=" ++ unMaple e1 f h ++ ".." ++ 
                  unMaple e2 f h ++ ")"
  uniformD e1 e2 = Maple $ \f h -> if f == True then  
                  show (1/((read (unMaple e2 f h) :: Double) - 
                  (read (unMaple e1 f h) :: Double))) ++ " * Sum (" 
                  else ", x" ++ show h ++ "=" ++ unMaple e1 f h ++ ".." ++ 
                  unMaple e2 f h ++ ")"                  
  normal e1 e2     = Maple $ \f h -> if f == True then  
                  "Int (PDF (Normal (" ++ unMaple e1 f h ++ ", " ++
                  unMaple e2 f h ++ ", x" ++ show h ++ ") * "  
                  else ", x" ++ show h ++ "=" ++ unMaple e1 f h ++ ".." ++ 
                  unMaple e2 f h ++ ")"              

instance Conditioning Maple where
  unconditioned = d2m
  conditioned   = d2m

view :: Maple a -> String
view e = unMaple e True 0

-- TEST CASES
exp1, exp2, exp3 :: Maple (Measure Double)
exp1 = unconditioned (uniform (real 1) (real 3)) `bind` ret

-- Borel's Paradox Simplified
exp2 = unconditioned (uniformD (real 1) (real 3)) `bind` \s ->
       unconditioned (uniform  (real (-1)) (real 1)) `bind` \x ->
       let y = s `mul` x in ret y

-- Borel's Paradox
exp3 = unconditioned (uniformD (real 1) (real 2)) `bind` \s ->
       unconditioned (uniform  (real (-1)) (real 1)) `bind` \x ->
       let y = (Language.Hakaru.Symbolic.sqrt ((real 1 ) `minus` 
               (Language.Hakaru.Symbolic.exp s (real 2)))) `mul`
               (Language.Hakaru.Symbolic.sin x) in ret y  

test, test2, test3 :: String
test = view exp1
test2 = view exp2
test3 = view exp3
{'fraction_non_alphanumeric': 0.14944377429299022, 'fraction_numerical': 0.016753786355716394, 'mean_word_length': 1.9216914643696164, 'pattern_counts': {'":': 0, '<': 3, '<?xml version=': 0, '>': 86, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 1, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '1975353', 'n_tokens_mistral': 2828, 'n_tokens_neox': 2561, 'n_words': 992}