Skip to content

Commit

Permalink
Starting to expand the definition of hist to work with multiple signa…
Browse files Browse the repository at this point in the history 
…tures. Issue #314
  • Loading branch information
@ozgurakgun
ozgurakgun committed Nov 8, 2016
1 parent e18252c commit 23d18ca
Show file tree
Hide file tree
Showing 5 changed files with 115 additions and 24 deletions.
18 changes: 11 additions & 7 deletions src/Conjure/Language/Expression/Op.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -101,7 +101,6 @@ mkOp op xs =
(arg xs 1 "inverse")
L_freq -> inject $ MkOpFreq $ OpFreq (arg xs 0 "freq")
(arg xs 1 "freq")
L_hist -> inject $ MkOpHist $ OpHist (arg xs 0 "hist")
L_parts -> inject $ MkOpParts $ OpParts (arg xs 0 "parts")
L_together -> inject $ MkOpTogether $ OpTogether (arg xs 0 "together")
(arg xs 1 "together")
Expand All @@ -118,13 +117,18 @@ mkOp op xs =
L_powerSet -> inject $ MkOpPowerSet $ OpPowerSet (arg xs 0 "powerSet")
L_concatenate -> inject $ MkOpFlatten $ OpFlatten (Just 1)
(arg xs 0 "concatenate")
L_hist ->
case xs of
[m] -> inject $ MkOpHist $ OpHistAll m
[m,n] -> inject $ MkOpHist $ OpHistForValues m n
_ -> bug "hist takes 1 or 2 arguments."
L_flatten ->
case xs of
[m] -> inject $ MkOpFlatten $ OpFlatten Nothing m
[n,m] ->
let n' = fromInteger $ fromMaybe (bug "The 1st argument of flatten has to be a constant integer.") (intOut "flatten" n)
in inject $ MkOpFlatten $ OpFlatten (Just n') m
_ -> bug "flatten takes 1 or 2 arguments."
case xs of
[m] -> inject $ MkOpFlatten $ OpFlatten Nothing m
[n,m] ->
let n' = fromInteger $ fromMaybe (bug "The 1st argument of flatten has to be a constant integer.") (intOut "flatten" n)
in inject $ MkOpFlatten $ OpFlatten (Just n') m
_ -> bug "flatten takes 1 or 2 arguments."
_ -> bug ("Unknown lexeme for operator:" <+> pretty (show l))

arg :: [a] -> Int -> Doc -> a
Expand Down
82 changes: 75 additions & 7 deletions src/Conjure/Language/Expression/Op/Hist.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -3,14 +3,35 @@
module Conjure.Language.Expression.Op.Hist where

import Conjure.Prelude
import Conjure.Bug
import Conjure.Language.Expression.Op.Internal.Common

import qualified Data.Aeson as JSON -- aeson
import qualified Data.HashMap.Strict as M -- unordered-containers
import qualified Data.Vector as V -- vector


data OpHist x = OpHist x
data OpHist x

= OpHistAll x -- histogram of all values
-- Has only one argument: the collection of values.
-- Produces a histogram of values in the form of a list-of-pairs,
-- where the first component is the value,
-- and the second component is the count.
-- There are no 0 count entries.

| OpHistForValues x x -- histogram of values-of-interest
-- Has two arguments: the collection of values,
-- and a list of values-of-interest.

-- Produces a histogram of values in the form of a list of counts,
-- one per each entry in the list of values-of-interest argument.
-- This is what's in the Essence paper, page 21, fig 4.

-- We extend the definition in the paper by allowing
-- a pair to represent lowerBound(inclusive) and upperBound(exclusive) of values.
-- Then, each bin contains values >=lb & <ub for the corresponding entry.

deriving (Eq, Ord, Show, Data, Functor, Traversable, Foldable, Typeable, Generic)

instance Serialize x => Serialize (OpHist x)
Expand All @@ -19,33 +40,80 @@ instance ToJSON x => ToJSON (OpHist x) where toJSON = genericToJSON jsonOp
instance FromJSON x => FromJSON (OpHist x) where parseJSON = genericParseJSON jsonOptions

instance (TypeOf x, Pretty x) => TypeOf (OpHist x) where
typeOf p@(OpHist a) = do
typeOf p@(OpHistAll a) = do
tyA <- typeOf a
case tyA of
TypeMSet aInner -> return $ TypeMatrix TypeInt $ TypeTuple [aInner, TypeInt]
TypeMatrix _ aInner -> return $ TypeMatrix TypeInt $ TypeTuple [aInner, TypeInt]
TypeList aInner -> return $ TypeMatrix TypeInt $ TypeTuple [aInner, TypeInt]
_ -> raiseTypeError p
typeOf p@(OpHistForValues a b) = do
tyA <- typeOf a
tyB <- typeOf b
case tyB of
TypeMatrix bIndex bInner ->
case tyA of
TypeMSet aInner | typeUnify aInner bInner -> return $ TypeMatrix bIndex TypeInt
TypeMatrix _ aInner | typeUnify aInner bInner -> return $ TypeMatrix bIndex TypeInt
TypeList aInner | typeUnify aInner bInner -> return $ TypeMatrix bIndex TypeInt
_ -> raiseTypeError p
_ -> raiseTypeError p

instance EvaluateOp OpHist where
evaluateOp (OpHist (viewConstantMSet -> Just cs)) = return $ ConstantAbstract $ AbsLitMatrix
evaluateOp (OpHistAll (viewConstantMSet -> Just cs)) = return $ ConstantAbstract $ AbsLitMatrix
(DomainInt [RangeBounded 1 (fromInt $ genericLength $ histogram cs)])
[ ConstantAbstract $ AbsLitTuple [e, ConstantInt n] | (e, n) <- histogram cs ]
evaluateOp (OpHist (viewConstantMatrix -> Just (_, cs))) = return $ ConstantAbstract $ AbsLitMatrix
evaluateOp (OpHistAll (viewConstantMatrix -> Just (_, cs))) = return $ ConstantAbstract $ AbsLitMatrix
(DomainInt [RangeBounded 1 (fromInt $ genericLength $ histogram cs)])
[ ConstantAbstract $ AbsLitTuple [e, ConstantInt n] | (e, n) <- histogram cs ]
evaluateOp op@(OpHistForValues
(viewConstantMSet -> Just cs)
(viewConstantMatrix -> Just (binIndex, bins))) =
return $ ConstantAbstract $ AbsLitMatrix binIndex
[ ConstantInt n
| bin <- bins
, let n = sum [ 1 | c <- cs
, case bin of
ConstantInt{} -> c == bin
ConstantAbstract (AbsLitTuple [lb, ub])
-> c >= lb && c < ub
_ -> bug $ "evaluateOp{OpHist}:" <++> pretty (show op)
]
]
evaluateOp op@(OpHistForValues
(viewConstantMatrix -> Just (_, cs))
(viewConstantMatrix -> Just (binIndex, bins))) =
return $ ConstantAbstract $ AbsLitMatrix binIndex
[ ConstantInt n
| bin <- bins
, let n = sum [ 1 | c <- cs
, case bin of
ConstantInt{} -> c == bin
ConstantAbstract (AbsLitTuple [lb, ub])
-> c >= lb && c < ub
_ -> bug $ "evaluateOp{OpHist}:" <++> pretty (show op)
]
]
evaluateOp op = na $ "evaluateOp{OpHist}:" <++> pretty (show op)

instance SimplifyOp OpHist x where
simplifyOp _ = na "simplifyOp{OpHist}"

instance Pretty x => Pretty (OpHist x) where
prettyPrec _ (OpHist a) = "hist" <> prParens (pretty a)
prettyPrec _ (OpHistAll a) = "hist" <> prParens (pretty a)
prettyPrec _ (OpHistForValues a b) = "hist" <> prettyList prParens "," [a,b]

instance VarSymBreakingDescription x => VarSymBreakingDescription (OpHist x) where
varSymBreakingDescription (OpHist a) = JSON.Object $ M.fromList
[ ("type", JSON.String "OpHist")
varSymBreakingDescription (OpHistAll a) = JSON.Object $ M.fromList
[ ("type", JSON.String "OpHistAll")
, ("children", JSON.Array $ V.fromList
[ varSymBreakingDescription a
])
]
varSymBreakingDescription (OpHistForValues a b) = JSON.Object $ M.fromList
[ ("type", JSON.String "OpHistForValues")
, ("children", JSON.Array $ V.fromList
[ varSymBreakingDescription a
, varSymBreakingDescription b
])
]
29 changes: 24 additions & 5 deletions src/Conjure/Language/Lenses.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -607,7 +607,7 @@ opFreq _ =
)


opHist
opHistAll
:: ( Op x :< x
, Pretty x
, MonadFail m
Expand All @@ -616,13 +616,32 @@ opHist
-> ( x -> x
, x -> m x
)
opHist _ =
( inject . MkOpHist . OpHist
opHistAll _ =
( inject . MkOpHist . OpHistAll
, \ p -> do
op <- project p
case op of
MkOpHist (OpHist x) -> return x
_ -> na ("Lenses.opHist:" <++> pretty p)
MkOpHist (OpHistAll x) -> return x
_ -> na ("Lenses.opHistAll:" <++> pretty p)
)


opHistForValues
:: ( Op x :< x
, Pretty x
, MonadFail m
)
=> Proxy (m :: * -> *)
-> ( x -> x -> x
, x -> m (x,x)
)
opHistForValues _ =
( \ x y -> inject (MkOpHist (OpHistForValues x y))
, \ p -> do
op <- project p
case op of
MkOpHist (OpHistForValues x y) -> return (x,y)
_ -> na ("Lenses.opHistForValues:" <++> pretty p)
)


Expand Down
8 changes: 4 additions & 4 deletions src/Conjure/Rules/Vertical/Matrix.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -155,7 +155,7 @@ rule_Comprehension_ToSet = "matrix-toSet" `namedRule` theRule where
, do
(iPat, i) <- quantifiedVar
let val = make opIndexing i 1
let over = make opHist matrix
let over = make opHistAll matrix
return $ Comprehension (upd val body)
$ gocBefore
++ [Generator (GenInExpr iPat over)]
Expand Down Expand Up @@ -207,13 +207,13 @@ rule_Comprehension_Nested = "matrix-comprehension-nested" `namedRule` theRule wh
theRule _ = na "rule_Comprehension_Nested"


rule_Comprehension_Hist :: Rule
rule_Comprehension_Hist = "matrix-hist" `namedRule` theRule where
rule_Comprehension_HistAll :: Rule
rule_Comprehension_HistAll = "matrix-histAll" `namedRule` theRule where
theRule (Comprehension body gensOrConds) = do
(gocBefore, (pat, expr), gocAfter) <- matchFirst gensOrConds $ \ goc -> case goc of
Generator (GenInExpr pat@Single{} expr) -> return (pat, expr)
_ -> na "rule_Comprehension_Hist"
matrix <- match opHist expr
matrix <- match opHistAll expr
TypeMatrix{} <- typeOf matrix
index:_ <- indexDomainsOf matrix
let upd val old = lambdaToFunction pat old val
Expand Down
2 changes: 1 addition & 1 deletion src/Conjure/UI/Model.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -988,7 +988,7 @@ verticalRules =
-- , Vertical.Matrix.rule_QuantifierAroundIndexedMatrixLiteral
, Vertical.Matrix.rule_Comprehension_LiteralIndexed
, Vertical.Matrix.rule_Comprehension_Nested
, Vertical.Matrix.rule_Comprehension_Hist
, Vertical.Matrix.rule_Comprehension_HistAll
, Vertical.Matrix.rule_Comprehension_ToSet
-- , Vertical.Matrix.rule_Comprehension_ToSet2
, Vertical.Matrix.rule_Matrix_Eq
Expand Down

0 comments on commit 23d18ca

Please sign in to comment.