From d8224b1041713f98905d562ea1e5e49b14d4dfd7 Mon Sep 17 00:00:00 2001 From: Nathaniel Wesley Filardo Date: Sun, 9 Dec 2012 15:57:16 -0500 Subject: [PATCH] Another day, another try at Analysis.RuleMode This time around, we're more dopaminergic. --- src/Dyna/Analysis/ANF.hs | 7 - src/Dyna/Analysis/RuleMode.hs | 298 +++++++++++++++++++++------------- 2 files changed, 184 insertions(+), 121 deletions(-) diff --git a/src/Dyna/Analysis/ANF.hs b/src/Dyna/Analysis/ANF.hs index 6821bdf..3379911 100644 --- a/src/Dyna/Analysis/ANF.hs +++ b/src/Dyna/Analysis/ANF.hs @@ -50,16 +50,9 @@ -- always want strong Boolean values (i.e. none of that three-values null -- stuff). -- --- it might be nice if terms came in with a type that verified that they are --- "flat term" -- they've been normalized. --- -- It would also be nice if spans were killed... maybe there is an argument -- against this. -- --- ANF Rule, `result` always the name of a variable -- it would be nice for --- its type were string in that case. Similarly, side conditions are always --- variables. --- -- Header material {{{ diff --git a/src/Dyna/Analysis/RuleMode.hs b/src/Dyna/Analysis/RuleMode.hs index 12752f5..266e098 100644 --- a/src/Dyna/Analysis/RuleMode.hs +++ b/src/Dyna/Analysis/RuleMode.hs @@ -1,6 +1,8 @@ --------------------------------------------------------------------------- -- | Mode analysis of a rule -- +-- Takes input from "Dyna.Analysis.ANF" +-- -- XXX Gotta start somewhere. -- Header material {{{ @@ -39,7 +41,7 @@ filterNTs = MA.mapMaybe isNTVar ------------------------------------------------------------------------}}} -- 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 @@ -49,58 +51,179 @@ varMode c (NTVar v) = if v `S.member` c then MBound else MFree 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) @@ -124,26 +247,47 @@ stepAgenda st sc = go 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 @@ -154,89 +298,14 @@ plan st sc (fr, anfs) cr@(c,ci,co) = } 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 @@ -244,7 +313,8 @@ main :: IO () 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)." -- 2.50.1