import qualified Data.IntMap as IM
import qualified Data.Set as S
-- import qualified Debug.Trace as XT
+import Dyna.Main.Defns
import qualified Dyna.ParserHS.Parser as P
import Dyna.Term.TTerm
import Dyna.Term.Normalized
------------------------------------------------------------------------}}}
-- Normalize a Rule {{{
-data Rule = Rule { r_index :: Int
+data Rule = Rule { r_index :: RuleIx
, r_head :: DVar
, r_aggregator :: DAgg
, r_result :: DVar
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE Rank2Types #-}
+{-# OPTIONS_GHC -Wall #-}
module Dyna.Analysis.DOpAMine where
import Control.Lens
import Dyna.Analysis.Mode.Det
import Dyna.Analysis.Mode.Execution.NamedInst
+import Dyna.Main.Defns
import Dyna.Term.Normalized
import Dyna.Term.TTerm
import Text.PrettyPrint.Free
-- @OPWrap x ys f ; OPIndr z x@ is indistinguishable from
-- @OPIter (MF z) (map MB ys) f DetSemi Nothing@.
| OPIndr DVar DVar -- -+
+
+ -- | Emit (i.e. yield) an answer. Parameters are the
+ -- head, value, rule index, and a list of variables
+ -- guaranteed to uniquely (together with the rule index)
+ -- identify this particular answer.
+ | OPEmit DVar DVar RuleIx [DVar]
+
deriving (Show)
{- XXX Move DOpAMine to being more functional, rather than a list of
- - opcodes?
+ - opcodes!
-
- OPBlock [DOpAMine bscg]
- OPOrElse [DOpAMine bscg] -- choice points!
OPWrap _ _ _ -> Det
OPIndr _ _ -> DetSemi
OPIter _ _ _ d _ -> d
+ OPEmit _ _ _ _ -> Det
------------------------------------------------------------------------}}}
-- Rendering {{{
<> maybe empty
((space <>) . braces . e v vs f d)
b
+ r _ (OPEmit h v i vs) = text "OPEmit" <+> pretty h
+ <+> pretty v
+ <+> pretty i
+ <+> pretty vs
------------------------------------------------------------------------}}}
adornedQueries
) -} where
+import Control.Arrow (second)
import Control.Lens ((^.))
import Control.Monad
import Control.Monad.Error.Class
- 1
DetMulti -> 2
OPIndr _ _ -> 100
+ OPEmit _ _ _ _ -> 0
loops = fromIntegral . length . filter isLoop
bestPlan [] = Nothing
bestPlan plans = Just $ argmin fst (take 1000 plans)
-{-
+-- | Add the last Emit verb to a string of actions from the planner.
+--
+-- XXX This is certainly the wrong answer for a number of reasons, not the
+-- least of which is that it adds all variables to the identification set,
+-- when really we just want the nondeterministic set.
+finalizePlan :: Rule -> Actions fbs -> Actions fbs
+finalizePlan r d = d ++ [OPEmit (r_head r) (r_result r) (r_index r)
+ $ S.toList $ allCruxVars (r_cruxes r)]
+
-- | Given a normalized form and, optionally, an initial crux,
-- saturate the graph and get all the plans for doing so.
--
-- XXX This has no idea what to do about non-range-restricted rules.
-planUpdate_ :: BackendPossible fbs -- ^ Available steps
- -> (PartialPlan fbs -> Actions fbs -> Cost) -- ^ Scoring function
- -> S.Set (Crux DVar TBase) -- ^ Normal form
- -> (EvalCrux DVar, DVar, DVar) -- ^ Initial eval crux
- -> S.Set DVar
- -> [(Cost, Actions fbs)] -- ^ If there's a plan...
-planUpdate_ bp sc anf mic fv = planner_ (possible bp) sc anf (Just mic) S.empty fv
--}
-
planUpdate :: BackendPossible fbs
-> Rule
-> (PartialPlan fbs -> Actions fbs -> Cost)
-> (EvalCrux DVar, DVar, DVar)
-> SIMCtx DVar
-> Maybe (Cost, Actions fbs)
-planUpdate bp r sc anf mi ictx =
+planUpdate bp r sc anf mi ictx = fmap (second (finalizePlan r)) $
bestPlan $ planner_ (possible bp r) sc anf (Just mi) ictx
planInitializer :: BackendPossible fbs -> Rule -> Maybe (Cost, Actions fbs)
-planInitializer bp r =
+planInitializer bp r = fmap (second (finalizePlan r)) $
let cruxes = r_cruxes r in
bestPlan $ planner_ (possible bp r) simpleCost cruxes Nothing
(allFreeSIMCtx $ S.toList $ allCruxVars cruxes)
,(("log",1) , PDBS $ call "log" )
,(("exp",1) , PDBS $ call "exp" )
,(("eval",1) , PDBS $ call "None;exec " )
+ -- XXX not quite what we want, but something like this might
+ -- be nice to have.
+ -- ,(("pair",2) , PDBS $ call "" )
]
where
nullary v _ _ = v
"for" <+> (tupledOrUnderscore $ filterGround mo)
<+> "in" <+> functorIndirect "chart" f m <> pslice mo <> colon
+ -- XXX Ought to make i and vs conditional on... doing debugging or the
+ -- aggregator for this head caring. The latter is a good bit more
+ -- advanced than we are right now.
+pdope_ (OPEmit h r i vs) =
+ "emit" <> tupled [ pretty h
+ , pretty r
+ , pretty i
+ , varmap
+ ]
+ where
+ -- A python map of variable name to value
+ varmap = encloseSep lbrace rbrace comma
+ $ map (\v -> let v' = pretty v in dquotes v' <+> colon <+> v') vs
+
-- | Render a dopamine sequence's checks and loops above a (indended) core.
-pdope :: Actions PyDopeBS -> Doc e -> Doc e
-pdope _d _e = (indent 4 $ "for _ in [None]:")
- `above` (indent 8 $ go _d _e)
+pdope :: Actions PyDopeBS -> Doc e
+pdope _d = (indent 4 $ "for _ in [None]:")
+ `above` (indent 8 $ go _d)
where
- go [] = id
+ go [] = empty
go (x:xs) = let indents = case x of OPIter _ _ _ d _ -> d /= Det ; _ -> False
in above (pdope_ x)
. (if indents then indent 4 else id)
- . go xs
+ $ go xs
printPlanHeader :: Handle -> Rule -> Cost -> Maybe Int -> IO ()
displayIO fh $ renderPretty 1.0 100
$ "@initializer" <> parens (uncurry pfa $ MA.fromJust $ findHeadFA h ucruxes)
`above` "def" <+> char '_' <> tupled [] <+> colon
- `above` pdope dope emit
+ `above` pdope dope
<> line
- where
- emit = "emit" <> tupled [pretty h, pretty r]
-- XXX INDIR EVAL
printUpdate :: Handle -> Rule -> Maybe DFunctAr -> (DVar, DVar) -> Actions PyDopeBS -> IO ()
displayIO fh $ renderPretty 1.0 100
$ "@register" <> parens (pfa f a)
`above` "def" <+> char '_' <> tupled (map pretty [hv,v]) <+> colon
- `above` pdope dope emit
+ `above` pdope dope
<> line
- where
- emit = "emit" <> tupled [pretty h, pretty r]
------------------------------------------------------------------------}}}
-- Driver {{{
--- /dev/null
+---------------------------------------------------------------------------
+-- | Common defintions that seem not to have a better home.
+
+-- Header material {{{
+--
+module Dyna.Main.Defns where
+
+------------------------------------------------------------------------}}}
+-- Types {{{
+
+type RuleIx = Integer
+
+------------------------------------------------------------------------}}}
import Data.Monoid (mempty)
import Dyna.Analysis.Mode.Inst
import Dyna.Analysis.Mode.Uniq
+import Dyna.Main.Defns
import Dyna.Main.Exception
import Dyna.Term.TTerm (Annotation(..), TBase(..),
DFunct, DFunctAr, DVar)
| TBase TBase
deriving (D.Data,D.Typeable,Eq,Ord,Show)
-type RuleIx = Int
-
-- | Rules are not just terms because we want to make it very syntactically
-- explicit about the head being a term (though that's not an expressivity
-- concern -- just use the parenthesized texpr case) so that there is no
-- XXX add arity to key?
, _pcs_opertab :: EOT
, _pcs_operspec :: M.Map B.ByteString () -- XXX
- , _pcs_ruleix :: Int
+ , _pcs_ruleix :: RuleIx
}
$(makeLenses ''PCS)
projects / dyna2 / commitdiff