---------------------------------------------------------------------------
-- | Mode analysis of a rule
--
+-- Takes input from "Dyna.Analysis.ANF"
+--
-- XXX Gotta start somewhere.
-- Header material {{{
------------------------------------------------------------------------}}}
-- Modes {{{
-data Mode = MFree | MBound deriving (Eq,Ord,Show)
+data Mode = MBound | MFree deriving (Eq,Ord,Show)
-- | What things have thus far been bound under the plan?
type BindChart = S.Set DVar
varMode c (NTString _) = MBound
varMode c (NTNumeric _) = MBound
-type ModedNT = NT (Mode,DVar)
+type ModedVar = (Mode,DVar)
+
+data ModedNT = MF DVar
+ | MB NTV
+ deriving (Eq,Ord,Show)
modeOfMNT :: ModedNT -> Mode
-modeOfMNT (NTNumeric _) = MBound
-modeOfMNT (NTString _) = MBound
-modeOfMNT (NTVar (m,_)) = m
+modeOfMNT (MF _) = MFree
+modeOfMNT (MB _) = MBound
+
+ntvOfMNT :: ModedNT -> NTV
+ntvOfMNT (MB x) = x
+ntvOfMNT (MF v) = NTVar v
+
+isBound, isFree :: ModedNT -> Bool
+isBound = (== MBound) . modeOfMNT
+isFree = (== MFree) . modeOfMNT
+
+data Det = Det -- ^ Exactly one answer
+ | DetSemi -- ^ At most one answer
+ | DetNon -- ^ Unknown number of answers
+ deriving (Eq,Ord,Show)
------------------------------------------------------------------------}}}
-- Cruxes {{{
-type Crux n = (DFunct,[n],n)
+data CFunct = CFCall DFunct
+ | CFUnif DFunct
+ | CFAssign
+ | CFEval
+ deriving (Eq,Ord,Show)
+
+type Crux n = (CFunct,[n],n)
cruxMode :: Crux NTV -> BindChart -> Crux ModedNT
cruxMode (f,is,o) c = (f, map (mode c) is, mode c o)
where
- mode c x@(NTVar v) = NTVar (varMode c x, v)
- mode _ (NTString s) = NTString s
- mode _ (NTNumeric x) = NTNumeric x
+ mode c x@(NTVar v) = case varMode c x of
+ MBound -> MB x
+ MFree -> MF v
+ mode _ (NTString s) = MB (NTString s)
+ mode _ (NTNumeric x) = MB (NTNumeric x)
------------------------------------------------------------------------}}}
--- Steps, Actions, and Plans {{{
+-- DOpAMine {{{
-data Det = Det -- ^ Exactly one answer
- | DetSemi -- ^ At most one answer
- | DetNon -- ^ Unknown number of answers
+-- | Dyna OPerational Abstract MachINE
+--
+-- It makes us happy.
+
+-- Opcode Out In
+data DOpAMine = OPAssign DVar NTV -- -+
+ | OPCheck DVar NTV -- ++
+
+ | OPCheckFunctor DVar DFunct Int -- +
+ | OPGetArgs [DVar] DVar -- -+
+ | OPBuild DVar [NTV] DFunct -- -+
+
+ | OPCall DVar [NTV] DFunct -- -+
+ | OPIter ModedNT [ModedNT] DFunct -- ??
+ | OPIndirEval DVar DVar -- -+
deriving (Eq,Ord,Show)
-type Step = (DFunct, [ModedNT], ModedNT, Det)
+detOfDop :: DOpAMine -> Det
+detOfDop x = case x of
+ OPAssign _ _ -> Det
+ OPCheck _ _ -> DetSemi
+ OPCheckFunctor _ _ _ -> DetSemi
+ OPGetArgs _ _ -> Det
+ OPBuild _ _ _ -> Det
+ OPIndirEval _ _ -> DetSemi
+ OPCall _ _ _ -> Det
+ OPIter o is _ -> -- XXX
+ case (modeOfMNT o, foldr min MBound (map modeOfMNT is)) of
+ (MFree, MBound) -> DetSemi
+ _ -> DetNon
+
+------------------------------------------------------------------------}}}
+-- Actions {{{
+
+type Action = [DOpAMine]
+
+-- XXX
+isMath f = f `elem` ["^", "+", "-", "*", "/"]
+
+-- XXX This function really ought to be generated from some declarations in
+-- the source program, rather than hard-coded.
+possible :: Crux ModedNT -> [Action]
+possible (f,is,o) = case f of
+ -- XXX Indirect evaluation is not yet supported
+ CFEval -> []
+
+ -- Assign or check
+ CFAssign -> case is of
+ [i] -> case (i, o) of
+ (MF _, MF _) -> []
+ (MB i', MB o') -> let chk = "_chk" in
+ [[ OPAssign chk i'
+ , OPCheck chk o']]
+ (MF o', MB i') -> [[OPAssign o' i']]
+ (MB i', MF o') -> [[OPAssign o' i']]
+ _ -> []
+
+ -- Unification
+ CFUnif funct ->
+ case o of
+ -- If the output is free, the only supported case is when all
+ -- inputs are known.
+ MF o' -> if all isBound is
+ then let is' = map ntvOfMNT is
+ in [[OPBuild o' is' funct]]
+ else []
+ -- On the other hand, if the output is known, then any subset
+ -- of the inputs may be known and will be checked.
+ --
+ -- XXX Does not understand nonlinear patterns D:
+ MB (NTVar o') -> [ (OPCheckFunctor o' funct $ length is)
+ : (OPGetArgs is' o')
+ : map (\(c,x) -> (OPCheck c x)) cis
+ ]
+ where
+ mkChks n (MF i) = (i, Nothing)
+ mkChks n (MB v) = let chk = BC.pack $ "_chk_" ++ (show n)
+ in (chk, Just (chk, v))
+
+ (is',mcis) = unzip $ zipWith mkChks [0..] is
+ cis = MA.catMaybes mcis
+
+ -- Backward-chainable mathematics (this is such a hack XXX)
+ CFCall f | isMath f ->
+ if not $ all isBound is
+ then case inv f is o of
+ Nothing -> []
+ Just (f',is',o') -> [[OPCall o' is' f']]
+ else let is' = map ntvOfMNT is in
+ case o of
+ MF o' -> [[OPCall o' is' f]]
+ MB o' -> let cv = "_chk"
+ in [[OPCall cv is' f
+ ,OPCheck cv o'
+ ]]
+
+ CFCall f | otherwise -> [[OPIter o is f ]]
--- | A 'Step' that indicates a need to check two variables' values being
--- equal.
-checkStep :: NTV -> NTV -> Step
-checkStep ex va = ("=", [mode va], mode ex, DetSemi)
where
- mode x@(NTVar v) = NTVar (MBound, v)
- mode (NTString s) = NTString s
- mode (NTNumeric x) = NTNumeric x
+ inv "+" is o | length is == 2 && isBound o
+ = case L.partition isFree is of
+ ([MF fi],bis) -> Just ("-",map ntvOfMNT $ o:bis,fi)
+ _ -> Nothing
-type Action = [Step]
+ inv "-" [(MB x),(MF y)] (MB o)
+ = Just ("-",[x,o],y)
-type Score = Double
+ inv "-" [(MF x),(MB y)] (MB o)
+ = Just ("+",[o,y],x)
+ inv _ _ _ = Nothing
+
+
+------------------------------------------------------------------------}}}
+-- Plans {{{
+
+type Cost = Double
data PartialPlan = PP { pp_cruxes :: S.Set (Crux NTV)
, pp_binds :: BindChart
- , pp_score :: Score
+ , pp_score :: Cost
, pp_plan :: Action
}
stepPartialPlan :: (Crux ModedNT -> [Action])
- -> (PartialPlan -> Action -> Score)
+ -> (PartialPlan -> Action -> Cost)
-> PartialPlan
- -> Either (Score, Action) [PartialPlan]
+ -> Either (Cost, Action) [PartialPlan]
stepPartialPlan steps score p =
if S.null (pp_cruxes p)
then Left $ (pp_score p, pp_plan p)
Left df -> df : (go ps)
Right ps' -> go (ps'++ps)
-eval_cruxes = M.foldWithKey (\o i -> (crux o i :)) [] . as_evals
+------------------------------------------------------------------------}}}
+-- Costing Plans {{{
+
+simpleCost :: PartialPlan -> Action -> Cost
+simpleCost (PP { pp_score = osc }) act =
+ osc + sum (map stepCost act)
+ where
+ stepCost :: DOpAMine -> Double
+ stepCost x = case x of
+ OPAssign _ _ -> 0
+ OPCheck _ _ -> 1
+ OPCheckFunctor _ _ _ -> 0
+ OPGetArgs _ _ -> 0
+ OPBuild _ _ _ -> 0
+ OPCall _ _ _ -> 0
+ OPIter o is _ -> fromIntegral $ length $ filter isFree (o:is)
+ OPIndirEval _ _ -> 10
+
+------------------------------------------------------------------------}}}
+-- ANF to Cruxes {{{
+
+eval_cruxes = M.foldrWithKey (\o i -> (crux o i :)) [] . as_evals
where
crux :: DVar -> EVF -> Crux NTV
- crux o (Left v) = ("*",[NTVar v],NTVar o)
- crux o (Right (TFunctor n as)) = (n,as,NTVar o)
+ crux o (Left v) = (CFEval,[NTVar v],NTVar o)
+ crux o (Right (TFunctor n as)) = (CFCall n,as,NTVar o)
-unif_cruxes = M.foldWithKey (\o i -> (crux o i :)) [] . as_unifs
+unif_cruxes = M.foldrWithKey (\o i -> (crux o i :)) [] . as_unifs
where
crux :: DVar -> FDT -> Crux NTV
- crux o t@(TString s) = ("=",[NTString s], NTVar o)
- crux o t@(TNumeric n) = ("=",[NTNumeric n], NTVar o)
- crux o (TFunctor x as) = (B.append "&" x, as, NTVar o)
+ crux o t@(TString s) = (CFAssign,[NTString s], NTVar o)
+ crux o t@(TNumeric n) = (CFAssign,[NTNumeric n], NTVar o)
+ crux o (TFunctor x as) = (CFUnif x, as, NTVar o)
-- | Given a normalized form and an initial crux, saturate the graph and
-- get a plan for doing so.
plan :: (Crux ModedNT -> [Action])
- -> (PartialPlan -> Action -> Score)
+ -> (PartialPlan -> Action -> Cost)
-> (FDR, ANFState)
-> Crux NTV
- -> (Score, Action)
+ -> (Cost, Action)
plan st sc (fr, anfs) cr@(c,ci,co) =
let cruxes = eval_cruxes anfs
++ unif_cruxes anfs
}
in L.minimumBy (O.comparing fst) $ stepAgenda st sc [initPlan]
-------------------------------------------------------------------------}}}
--- Possible steps {{{
-
--- XXX
-isMath f = f `elem` ["^", "+", "-", "*", "/"]
-
--- XXX This function really ought to be generated from some declarations in
--- the source program, rather than hard-coded.
-possible :: Crux ModedNT -> [Action]
-possible (f,is,o) = case () of
- -- Check
- _ | f == "=" && length is == 1 -> [[("=",is,o,DetSemi)]]
-
- -- Unification
- _ | B.take 1 f == "&" ->
- let funct = B.drop 1 f in
- case modeOfMNT o of
- -- If the output is free, the only supported case is when all
- -- inputs are known.
- MFree -> if all isBound is
- then [[("&",is,o,Det)]]
- else []
- -- On the other hand, if the output is known, then any subset
- -- of the inputs may be known and will be checked.
- --
- -- XXX Does not understand nonlinear patterns D:
- MBound -> let chkf = "_chk_f"
- mkChks n x | isBound x
- = let chk = "_chk_" -- XXX
- in ( NTVar (MFree,chk)
- , Just (chk,x))
- mkChks _ x = (x, Nothing)
-
- (is',mcis) = unzip $ zipWith mkChks [0..] is
- cis = MA.catMaybes mcis
- in [ ("&",is',o,Det)
- : map (\(c,x) -> ("=",[NTVar (MBound,c)],x,DetSemi))
- cis
- ]
-
- -- Backward-chainable mathematics (this is such a hack XXX)
- _ | isMath f ->
- if not $ all isBound is
- then case inv f is o of
- Nothing -> []
- Just (f',is',o') -> [[(f',is',o',Det)]]
- else case modeOfMNT o of
- MFree -> [[(f,is,o,Det)]]
- MBound -> let cv = "_chk"
- in [[(f,is,NTVar (MFree,cv),DetSemi)
- ,("=",[NTVar (MBound,cv)],o,DetSemi)
- ]]
- _ | otherwise ->
- if all isBound (o:is)
- then let cv = "_chk"
- in [[(f,is,NTVar (MFree,cv),DetSemi)
- ,("=",[NTVar (MBound,cv)],o,DetSemi)
- ]]
- else [[(f,is,o,DetNon)]]
-
- where
- isBound = (== MBound) . modeOfMNT
- isFree = (== MFree) . modeOfMNT
-
- inv "+" is o | length is == 2 && isBound o
- = case L.partition isFree is of
- ([fi],bis) -> Just ("-",o:bis,fi)
-
- inv "-" [x,y] o | isBound x && isBound o && isFree y
- = Just ("-",[x,o],y)
-
- inv "-" [x,y] o | isBound y && isBound o && isFree x
- = Just ("+",[o,y],x)
-
- inv _ _ _ = Nothing
-
------------------------------------------------------------------------}}}
-- Experimental Detritus {{{
+
testPlanRule x =
let (fr,anfs) = runNormalize $ normRule (unsafeParse DP.drule x)
- updatePlans = map (\c -> (c, plan possible (\_ _ -> 0) (fr,anfs) c))
- $ filter (\(f,_,_) -> not $ isMath f)
+ updatePlans = map (\c -> (c, plan possible simpleCost (fr,anfs) c))
+ $ filter (\(f,_,_) -> case f of { CFCall f' -> not $ isMath f' ; _ -> False })
$ eval_cruxes anfs
in updatePlans
main = mapM_ (\(c,(s,p)) -> do
putStrLn $ show c
putStrLn $ "SCORE: " ++ show s
- forM_ p (putStrLn . show))
+ forM_ p (putStrLn . show)
+ putStrLn "")
$ testPlanRule
-- $ "fib(X) :- fib(X-1) + fib(X-2)"
$ "path(pair(Y,Z),V) min= path(pair(X,Y),U) + cost(X,Y,Z,U,V)."
projects / dyna2 / commitdiff