This commit is known to break Dyna.Analysis.RuleModeTest; sorry.
| NTVar v
deriving (Eq,Ord,Show)
+instance (Pretty v) => Pretty (NT v) where
+ pretty (NTNumeric (Left x)) = pretty x
+ pretty (NTNumeric (Right x)) = pretty x
+ pretty (NTString s) = dquotes (pretty s)
+ pretty (NTVar v) = pretty v
+
+
-- | Normalized Term over 'DVar' (that is, either a primitive or a variable)
type NTV = NT DVar
, parens $ text "result" <+> (pretty result)
]
where
- pnt :: (Pretty v) => NT v -> Doc e
- pnt (NTNumeric (Left x)) = pretty x
- pnt (NTNumeric (Right x)) = pretty x
- pnt (NTString s) = dquotes (pretty s)
- pnt (NTVar v) = pretty v
pft :: FDT -> Doc e
pft (fn,args) = parens $ hsep $ (pretty fn : (map pretty args))
pevf (Right t) = pft t
penf :: ENF -> Doc e
- penf (Left n) = pnt n
+ penf (Left n) = pretty n
penf (Right t) = pft t
pev x = valign $ map (\(y,z)-> parens $ pretty y <+> pevf z) $ M.toList x
-- Opcode Out In Ancillary
data DOpAMine = OPAssign DVar NTV -- -+
- | OPCheck DVar NTV -- ++
+ | OPCheck DVar DVar -- ++
| OPGetArgsIf [DVar] DVar DFunct Int -- -+
- | OPBuild DVar [NTV] DFunct -- -+
+ | OPBuild DVar [DVar] DFunct -- -+
| OPCall DVar [NTV] DFunct -- -+
| OPIter (ModedVar) [ModedVar] DFunct -- ??
(Left _, MF _) -> []
(Right _, MB o') -> let chk = "_chk" in
[[ OPAssign chk ni
- , OPCheck chk (NTVar o')]]
+ , OPCheck chk o']]
(Left i', MB o') -> [[OPAssign i' (NTVar o')]]
(Right _, MF o') -> [[OPAssign o' ni]]
-- If the output is free, the only supported case is when all
-- inputs are known.
MF o' -> if all isBound is
- then [[OPBuild o' (map (NTVar . varOfMV) is) funct]]
+ then [[OPBuild o' (map varOfMV 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.
MB o' -> [ (OPGetArgsIf is' o' funct $ length is)
- : map (\(c,x) -> (OPCheck c (NTVar x))) cis
+ : map (\(c,x) -> (OPCheck c x)) cis
]
where
mkChks _ (MF i) = (i, Nothing)
MF o' -> [[OPCall o' is' funct]]
MB o' -> let cv = "_chk"
in [[OPCall cv is' funct
- ,OPCheck cv (NTVar o')
+ ,OPCheck cv o'
]]
-- Otherwise, we assume it's an extensional table and ask to iterate
type Cost = Double
+-- XXX I don't understand why this heuristic works, but it seems to exclude
+-- some of the... less intelligent plans.
simpleCost :: PartialPlan -> Action -> Cost
-simpleCost (PP { pp_score = osc }) act =
- osc + sum (map stepCost act)
+simpleCost (PP { pp_score = osc, pp_plan = pfx }) act =
+ 2 * osc + (1 + loops pfx) * actCost act
where
+ actCost = sum . map stepCost
+
stepCost :: DOpAMine -> Double
stepCost x = case x of
- OPAssign _ _ -> 0
- OPCheck _ _ -> 1
- OPGetArgsIf _ _ _ _ -> 0
- OPBuild _ _ _ -> 0
- OPCall _ _ _ -> 0
- OPIter o is _ -> fromIntegral $ length $ filter isFree (o:is)
- OPIndirEval _ _ -> 10
+ OPAssign _ _ -> 1
+ OPCheck _ _ -> 2
+ OPGetArgsIf _ _ _ _ -> 1
+ OPBuild _ _ _ -> 1
+ OPCall _ _ _ -> 1
+ OPIter o is _ -> 2 * (fromIntegral $ length $ filter isFree (o:is))
+ OPIndirEval _ _ -> 100
+
+ loops = fromIntegral . length . filter isLoop
+
+ isLoop :: DOpAMine -> Bool
+ isLoop = (== DetNon) . detOfDop
------------------------------------------------------------------------}}}
-- Planning {{{
--
-- XXX If the intial entrypoint is nonlinear, we need to insert some
-- checks into the plan. Fixing that is moderately invasive...
-plan :: (Crux (ModedVar) (ModedNT) -> [Action]) -- ^ Available steps
- -> (PartialPlan -> Action -> Cost) -- ^ Scoring function
- -> ANFState -- ^ Normal form
- -> Crux DVar NTV -- ^ Initial crux
- -> DVar -- ^ Head Intern
- -> DVar -- ^ Value
- -> Maybe (Cost, Action) -- ^ If there's a plan...
-plan st sc anf cr hi v =
+plan_ :: (Crux (ModedVar) (ModedNT) -> [Action]) -- ^ Available steps
+ -> (PartialPlan -> Action -> Cost) -- ^ Scoring function
+ -> ANFState -- ^ Normal form
+ -> Crux DVar NTV -- ^ Initial crux
+ -> DVar -- ^ Head Intern
+ -> DVar -- ^ Value
+ -> [(Cost, Action)] -- ^ If there's a plan...
+plan_ st sc anf cr hi v =
let cruxes = eval_cruxes anf
++ unif_cruxes anf
initPlan = PP { pp_cruxes = S.delete cr (S.fromList cruxes)
, pp_score = 0
, pp_plan = initialPlanForCrux hi v cr
}
- in case stepAgenda st sc [initPlan] of
- [] -> Nothing
- plans -> Just $ L.minimumBy (O.comparing fst) plans
+ in stepAgenda st sc [initPlan]
+
+plan st sc anf cr hi v =
+ (\x -> case x of
+ [] -> Nothing
+ plans -> Just $ L.minimumBy (O.comparing fst) plans)
+ $ plan_ st sc anf cr hi v
planEachEval :: DVar -> DVar -> ANFState -> [(DFunctAr, Maybe (Cost,Action))]
planEachEval hi v anf =
main = mapM_ (\(c,msp) -> do
putStrLn $ show c
case msp of
- Just (s,p) -> do
- putStrLn $ "SCORE: " ++ show s
- forM_ p (putStrLn . show)
- Nothing -> putStrLn "NO PLAN"
+ Nothing -> putStrLn "NO PLAN"
+ Just sps -> forM_ [sps] $ \(s,p) -> do
+ putStrLn $ "SCORE: " ++ show s
+ forM_ p (putStrLn . show)
putStrLn "")
- $ testPlanRule
+ $ take 1 $ 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)."
- "goal += f(&pair(Y,Y))."
+ "path(pair(Y,Z),V) min= path(pair(X,Y),1,U) + cost(X,Y,Z,U,V)."
+ -- "goal += f(&pair(Y,Y))."
------------------------------------------------------------------------}}}
prettyPlans src =
let rules = map (toANF.unspan) $ unsafeParse dlines src
- plans = map (planEachEval.snd) $ rules
+ plans = map (planEachEval "_H" "_V" . snd) $ rules
in
show $ (vcat $ zipWith pp plans rules)
-
-- XXX perhaps "base cases" of the universe (constants) should be interned if
-- they are going to be used in terms. Probably want to skip doubles; Interning
-- integers seems silly but not bad; interning strings seems like a good idea.
-
pp p ((FRule h a e result), _) = valign $ map f p
where
emit = "emit" <+> tupled [pretty h, pretty result]
- f (c@(CFCall f, ns, n), Just plan) = valign [ "def update_" <> pretty f <> "(id, value):" -- TODO: need unique variable names for id and value
+ f (c@(CFCall n ns f), Just plan) = valign [ "def update_" <> pretty f <> "(id, value):" -- TODO: need unique variable names for id and value
, "#" <+> pcrux c
- , (tupled $ map pnt ns) <+> "= load(update_id)" -- TODO: should be all vars
- , pnt n <+> "= value" -- TODO: return shouldn't be pnt
+ , (tupled $ map pretty ns) <+> "= load(update_id)" -- TODO: should be all vars
+ , pretty n <+> "= value" -- TODO: return shouldn't be pnt
, pplan plan
, emit]
f (crux, Nothing) = error $ "Did not find a plan for " ++ (show $ pcrux crux)
pplan (_, action) = valign $ map pdope action
- pcrux (CFCall f, ns, n) = pnt n <+> equals <+> pred f ns
+ pcrux (CFCall n ns f) = pretty n <+> equals <+> pred f ns
pdope (OPIndirEval _ _) = error "indirect evaluation not implemented"
- pdope (OPAssign v val) = pretty v <+> equals <+> pnt val
- pdope (OPCheck v val) = hsep ["assert", pretty v, "==", pnt val]
+ pdope (OPAssign v val) = pretty v <+> equals <+> pretty val
+ pdope (OPCheck v val) = hsep ["assert", pretty v, "==", pretty val]
- pdope (OPGetArgs vs id) = tupled (map pretty vs) <+> equals <+> "peel" <> (parens $ pretty id)
- pdope (OPCheckFunctor v f a) = "check" <+> pretty f <> tupled [text $ show a, pretty v]
+ pdope (OPGetArgsIf vs id f a) = "gaif" <+> tupled (map pretty vs) <+> equals <+> "peel" <> parens (pretty f <> "/" <> pretty a) <> (parens $ pretty id)
pdope (OPBuild v vs f) = pretty v <+> equals <+> "build" <+> pred f vs
pdope (OPCall v vs f) = pretty v <+> equals <+> "call" <+> pred f vs
"for" <+> (tupled $ filterBound mo) <+> "in" <+> pretty f <> slice mo
- slice = brackets . sepBy "," . map (\x -> case x of (MF v) -> ":" ; (MB v) -> pnt v)
+ slice = brackets . sepBy "," . map (\x -> case x of (MF v) -> ":" ; (MB v) -> pretty v)
filterBound = map (\(MF v) -> pretty v) . filter (not.isBound)
- pred f vs = pretty f <> (tupled $ map pnt vs)
-
- pnt (NTNumeric (Left x)) = pretty x
- pnt (NTNumeric (Right x)) = pretty x
- pnt (NTString s) = dquotes (pretty s)
- pnt (NTVar v) = pretty v
-
+ pred f vs = pretty f <> (tupled $ map pretty vs)
writePlans file = do
contents <- B.readFile file
module Dyna.Backend.Python where
-import Control.Arrow
+import qualified Control.Arrow as A
import Control.Exception
import Control.Monad
import qualified Data.ByteString as B
import qualified Dyna.ParserHS.Parser as P
import Dyna.XXX.PPrint
import Dyna.XXX.TrifectaTest
+import System.IO
import Text.PrettyPrint.Free
import qualified Text.Trifecta as T
instance Exception TopLevelException
+------------------------------------------------------------------------}}}
+-- DOpAMine Printout {{{
+
+-- XXX This is ripped out of Dyna.Analysis.RuleModeTest and ported over.
+-- Sorry, Tim.
+
+pdope :: DOpAMine -> Doc e
+pdope (OPIndirEval _ _) = error "indirect evaluation not implemented"
+pdope (OPAssign v val) = pretty v <+> equals <+> pretty val
+pdope (OPCheck v val) = hsep ["assert", pretty v, "==", pretty val]
+pdope (OPGetArgsIf vs id f a) =
+ tupled (map pretty vs)
+ <+> equals
+ <+> "peel" <> parens (pretty f <> "/" <> pretty a)
+ <> (parens $ pretty id)
+pdope (OPBuild v vs f) = pretty v <+> equals <+> "build" <+> pf f vs
+pdope (OPCall v vs f) = pretty v <+> equals <+> "call" <+> pf f vs
+pdope (OPIter o m f) =
+ let mo = m ++ [o] in
+ "for" <+> (tupled $ filterBound mo)
+ <+> "in" <+> pretty f <> pslice mo
+
+pslice = brackets . sepBy ","
+ . map (\x -> case x of (MF v) -> ":" ; (MB v) -> pretty v)
+
+filterBound = map (\(MF v) -> pretty v) . filter (not.isBound)
+
+pf f vs = pretty f <> (tupled $ map pretty vs)
+
------------------------------------------------------------------------}}}
-- Experimental Detritus {{{
--
-- XXX This guy wants span information.
combinePlans :: [(FDR,[(DFunctAr, Maybe (Cost,Action))])] ->
- Either String (M.Map DFunctAr [Action])
+ Either String (M.Map DFunctAr [(Cost,Action)])
combinePlans = go (M.empty)
where
go m [] = Right m
go m ((fr,cmca):xs) = go' xs fr cmca m
go' xs _ [] m = go m xs
- go' xs fr ((c,mca):ys) m =
+ go' xs fr ((fa,mca):ys) m =
case mca of
- Nothing -> Left $ "No plan for " ++ (show c)
+ Nothing -> Left $ "No plan for " ++ (show fa)
++ " in " ++ (show fr)
- Just (_,a) -> go' xs fr ys $ iora c a m
+ Just ca -> go' xs fr ys $ iora fa ca m
-- Insert OR Append
iora :: (Ord k) => k -> v -> M.Map k [v] -> M.Map k [v]
Left e -> throw $ TLEAggPlan e
Right a -> return a
cPlans <- case combinePlans
- $ map (second $ planEachEval headVar valVar)
+ $ map (A.second $ planEachEval headVar valVar)
franfs of
Left e -> throw $ TLEUpdPlan e
Right a -> return a
forM_ (M.toList cPlans) $ \(c,ps) -> do
print c
- forM_ ps $ \p -> do
- print ps
+ forM_ ps $ \(c,p) -> do
+ putStrLn $ "# Cost: " ++ (show c)
+ displayIO stdout $ renderPretty 1.0 100 $ vsep $ map pdope p
putStrLn ""
+ putStrLn ";"
+ putStrLn ""
where
headVar = "_H"
valVar = "_V"
+-- TEST: processFile "examples/cky.dyna"
+
------------------------------------------------------------------------}}}
-- Experimental Residuals? {{{
projects / dyna2 / commitdiff