mirror of
https://github.com/aaronallen8455/graph-trace.git
synced 2024-09-11 09:05:34 +03:00
rename predicates
This commit is contained in:
parent
d29a307d88
commit
d9e28977bf
@ -3,9 +3,9 @@ module Class where
|
||||
import Graph.Trace
|
||||
|
||||
class Show a => Classy a where
|
||||
classy :: Debug => a -> String
|
||||
classy :: Trace => a -> String
|
||||
|
||||
deff :: Debug => a -> String
|
||||
deff :: Trace => a -> String
|
||||
deff = show
|
||||
|
||||
class Show a => Classier a where
|
||||
|
@ -21,7 +21,7 @@ import Class
|
||||
import qualified System.Random as Rand
|
||||
import System.IO.Unsafe
|
||||
|
||||
main :: DebugDeep => IO ()
|
||||
main :: TraceDeep => IO ()
|
||||
main = trace bah print unassuming >> buzzard
|
||||
where
|
||||
unassuming :: Either Bool Int
|
||||
|
@ -1,96 +0,0 @@
|
||||
{-# OPTIONS_GHC -fno-cse -fno-full-laziness #-}
|
||||
{-# LANGUAGE MultiWayIf #-}
|
||||
import Control.Applicative (empty)
|
||||
import Control.Monad
|
||||
import Control.Monad.ST
|
||||
import Control.Monad.Trans (lift)
|
||||
import Control.Monad.Trans.Maybe
|
||||
import Control.Monad.Trans.State.Strict
|
||||
import Data.Bits
|
||||
import qualified Data.ByteString.Char8 as BS8
|
||||
import Data.Foldable (for_)
|
||||
import qualified Data.HashMap.Strict as HM
|
||||
import qualified Data.Vector.Generic.Mutable as MV
|
||||
import qualified Data.Vector.Unboxed.Mutable as UMV
|
||||
|
||||
import Graph.Trace
|
||||
|
||||
type ItemName = BS8.ByteString
|
||||
type Pair = (ItemName, ItemName)
|
||||
type SetIndex = Int
|
||||
-- A "Set" consists of two groups of items which cannot be bought together.
|
||||
type ItemToSet = HM.HashMap ItemName (SetIndex, Bool)
|
||||
-- The Bool indicates which "side" of the Set an item belongs to
|
||||
type Resolver s = UMV.MVector s (SetIndex, Bool)
|
||||
-- Sets can combined by mapping the SetIndex of the merged Set to the index of
|
||||
-- another Set using a mutable vector.
|
||||
-- The Bool is True if the groups in the Set being merged should be flipped.
|
||||
|
||||
main :: DebugDeep => IO ()
|
||||
main = do
|
||||
n <- readLn
|
||||
items <- replicateM n BS8.getLine
|
||||
m <- readLn
|
||||
pairs <- map ((\[x, y] -> (x, y)) . BS8.words) <$> replicateM m BS8.getLine
|
||||
case runST $ solve items pairs of
|
||||
Nothing -> putStrLn "impossible"
|
||||
Just (jesse, walt) -> do
|
||||
BS8.putStrLn $ BS8.unwords jesse
|
||||
BS8.putStrLn $ BS8.unwords walt
|
||||
|
||||
solve :: [ItemName] -> [Pair] -> ST s (Maybe ([ItemName], [ItemName]))
|
||||
solve items pairs = do
|
||||
-- kattis uses an old version of vector w/o generate
|
||||
--resolver <- MV.generate 50000 (,False)
|
||||
resolver <- MV.new 50000
|
||||
for_ [0..49999] $ \i -> MV.write resolver i (i, False)
|
||||
mItemToSet <- (`evalStateT` 0) . runMaybeT
|
||||
$ foldM (step resolver) HM.empty pairs
|
||||
forM mItemToSet $ \itemToSet ->
|
||||
foldM (assign resolver itemToSet) ([], []) items
|
||||
|
||||
step :: Resolver s -> ItemToSet -> Pair -> MaybeT (StateT SetIndex (ST s)) ItemToSet
|
||||
step resolver itemToSet (a, b) =
|
||||
case (HM.lookup a itemToSet, HM.lookup b itemToSet) of
|
||||
(Nothing, Nothing) -> do
|
||||
ix <- lift get
|
||||
lift $ modify' succ
|
||||
pure . HM.insert a (ix, True) $ HM.insert b (ix, False) itemToSet
|
||||
(Just (ix, o), Nothing) ->
|
||||
pure $ HM.insert b (ix, not o) itemToSet
|
||||
(Nothing, Just (ix, o)) ->
|
||||
pure $ HM.insert a (ix, not o) itemToSet
|
||||
(Just (aix, ao), Just (bix, bo)) -> do
|
||||
(aix', ao') <- lift . lift $ resolve resolver aix ao
|
||||
(bix', bo') <- lift . lift $ resolve resolver bix bo
|
||||
-- compress paths
|
||||
let itemToSet' | aix /= aix' || bix /= bix'
|
||||
= HM.insert a (aix', ao')
|
||||
$ HM.insert b (bix', bo') itemToSet
|
||||
| otherwise = itemToSet
|
||||
if | aix' == bix', ao' == bo' -> empty -- fail
|
||||
| aix' == bix' -> pure itemToSet'
|
||||
| otherwise -> do
|
||||
lift . lift $ UMV.write resolver bix' (aix', ao' == bo')
|
||||
pure itemToSet'
|
||||
|
||||
assign :: Resolver s
|
||||
-> ItemToSet
|
||||
-> ([ItemName], [ItemName])
|
||||
-> ItemName
|
||||
-> ST s ([ItemName], [ItemName])
|
||||
assign resolver itemToSet (jesse, walt) item =
|
||||
case HM.lookup item itemToSet of
|
||||
Nothing -> pure (jesse, item : walt)
|
||||
Just (ix, b) -> do
|
||||
(_, b') <- resolve resolver ix b
|
||||
pure $ if b' then (item : jesse, walt) else (jesse, item : walt)
|
||||
|
||||
resolve :: Resolver s -> SetIndex -> Bool -> ST s (SetIndex, Bool)
|
||||
resolve resolver ix b = do
|
||||
(ix', b') <- UMV.read resolver ix
|
||||
let b'' = xor b b'
|
||||
if ix' == ix
|
||||
then pure (ix, b'')
|
||||
else resolve resolver ix' b''
|
||||
|
@ -1,9 +0,0 @@
|
||||
5
|
||||
battery_acid
|
||||
drain_cleaner
|
||||
antifreeze
|
||||
cold_medicine
|
||||
lantern_fuel
|
||||
2
|
||||
cold_medicine battery_acid
|
||||
antifreeze lantern_fuel
|
@ -34,11 +34,3 @@ executable test-exe
|
||||
-- hs-source-dirs:
|
||||
default-language: Haskell2010
|
||||
-- ghc-options: -fplugin=Graph.Trace
|
||||
|
||||
executable breaking
|
||||
main-is: Main.hs
|
||||
hs-source-dirs: breaking
|
||||
build-depends: base, graph-trace, vector, unordered-containers, bytestring,
|
||||
mtl, transformers
|
||||
default-language: Haskell2010
|
||||
ghc-options: -fplugin=Graph.Trace
|
||||
|
@ -61,12 +61,12 @@ renamedResultAction cmdLineOptions tcGblEnv
|
||||
debugTypesModule <- findImportedModule "Graph.Trace.Internal.Types"
|
||||
debugTraceModule <- findImportedModule "Graph.Trace.Internal.Trace"
|
||||
|
||||
debugMutePredName <- Ghc.lookupOrig debugTypesModule (Ghc.mkClsOcc "DebugMute")
|
||||
debugDeepPredName <- Ghc.lookupOrig debugTypesModule (Ghc.mkClsOcc "DebugDeep")
|
||||
debugDeepKeyPredName <- Ghc.lookupOrig debugTypesModule (Ghc.mkClsOcc "DebugDeepKey")
|
||||
debugPredName <- Ghc.lookupOrig debugTypesModule (Ghc.mkClsOcc "Debug")
|
||||
debugKeyPredName <- Ghc.lookupOrig debugTypesModule (Ghc.mkClsOcc "DebugKey")
|
||||
debugInertPredName <- Ghc.lookupOrig debugTypesModule (Ghc.mkClsOcc "DebugInert")
|
||||
traceMutePredName <- Ghc.lookupOrig debugTypesModule (Ghc.mkClsOcc "TraceMute")
|
||||
traceDeepPredName <- Ghc.lookupOrig debugTypesModule (Ghc.mkClsOcc "TraceDeep")
|
||||
traceDeepKeyPredName <- Ghc.lookupOrig debugTypesModule (Ghc.mkClsOcc "TraceDeepKey")
|
||||
tracePredName <- Ghc.lookupOrig debugTypesModule (Ghc.mkClsOcc "Trace")
|
||||
traceKeyPredName <- Ghc.lookupOrig debugTypesModule (Ghc.mkClsOcc "TraceKey")
|
||||
traceInertPredName <- Ghc.lookupOrig debugTypesModule (Ghc.mkClsOcc "TraceInert")
|
||||
entryName <- Ghc.lookupOrig debugTraceModule (Ghc.mkVarOcc "entry")
|
||||
debugContextName <- Ghc.lookupOrig debugTypesModule (Ghc.mkTcOcc "DebugContext")
|
||||
|
||||
|
@ -74,8 +74,8 @@ addConstraintToSigType debugNames debugAllFlag names sig@(Ghc.HsSig' t) = do
|
||||
prop = if debugAllFlag then Shallow else Inert
|
||||
predName =
|
||||
if debugAllFlag
|
||||
then debugPredName debugNames
|
||||
else debugInertPredName debugNames
|
||||
then tracePredName debugNames
|
||||
else traceInertPredName debugNames
|
||||
predTy = Ghc.noLocA'
|
||||
$ Ghc.HsTyVar Ghc.emptyEpAnn Ghc.NotPromoted
|
||||
(Ghc.noLocA' predName)
|
||||
@ -119,14 +119,14 @@ checkForDebugPred
|
||||
-> Maybe (Maybe Ghc.FastString, Propagation)
|
||||
checkForDebugPred debugNames
|
||||
(Ghc.HsTyVar _ _ (Ghc.L _ name))
|
||||
| name == debugPredName debugNames = Just (Nothing, Shallow)
|
||||
| name == debugDeepPredName debugNames = Just (Nothing, Deep)
|
||||
| name == debugMutePredName debugNames = Just (Nothing, Mute)
|
||||
| name == debugInertPredName debugNames = Just (Nothing, Inert)
|
||||
| name == tracePredName debugNames = Just (Nothing, Shallow)
|
||||
| name == traceDeepPredName debugNames = Just (Nothing, Deep)
|
||||
| name == traceMutePredName debugNames = Just (Nothing, Mute)
|
||||
| name == traceInertPredName debugNames = Just (Nothing, Inert)
|
||||
checkForDebugPred debugNames
|
||||
(Ghc.HsAppTy _ (Ghc.L _ (Ghc.HsTyVar _ _ (Ghc.L _ name))) (Ghc.L _ (Ghc.HsTyLit _ (Ghc.HsStrTy _ key))))
|
||||
| name == debugKeyPredName debugNames = Just (Just key, Shallow)
|
||||
| name == debugDeepKeyPredName debugNames = Just (Just key, Deep)
|
||||
| name == traceKeyPredName debugNames = Just (Just key, Shallow)
|
||||
| name == traceDeepKeyPredName debugNames = Just (Just key, Deep)
|
||||
checkForDebugPred debugNames Ghc.HsForAllTy { Ghc.hst_body = Ghc.L _ ty }
|
||||
= checkForDebugPred debugNames ty
|
||||
checkForDebugPred debugNames (Ghc.HsParTy _ (Ghc.L _ ty))
|
||||
|
@ -12,12 +12,12 @@ module Graph.Trace.Internal.Types
|
||||
, DefinitionSite
|
||||
, CallSite
|
||||
, DebugIP
|
||||
, DebugMute
|
||||
, DebugDeep
|
||||
, DebugDeepKey
|
||||
, Debug
|
||||
, DebugKey
|
||||
, DebugInert
|
||||
, TraceMute
|
||||
, TraceDeep
|
||||
, TraceDeepKey
|
||||
, Trace
|
||||
, TraceKey
|
||||
, TraceInert
|
||||
, Event(..)
|
||||
, eventToLogStr
|
||||
, FunName
|
||||
@ -66,12 +66,12 @@ type DefinitionSite = SrcCodeLoc
|
||||
type CallSite = SrcCodeLoc
|
||||
|
||||
type DebugIP = (?_debug_ip :: Maybe DebugContext, HasCallStack)
|
||||
type DebugMute = DebugIP
|
||||
type DebugDeep = DebugIP
|
||||
type DebugDeepKey (key :: Symbol) = DebugIP
|
||||
type Debug = DebugIP
|
||||
type DebugKey (key :: Symbol) = DebugIP
|
||||
type DebugInert = DebugIP
|
||||
type TraceMute = DebugIP
|
||||
type TraceDeep = DebugIP
|
||||
type TraceDeepKey (key :: Symbol) = DebugIP
|
||||
type Trace = DebugIP
|
||||
type TraceKey (key :: Symbol) = DebugIP
|
||||
type TraceInert = DebugIP
|
||||
-- These are String because they need to be lifted into TH expressions
|
||||
type FunName = String
|
||||
type UserKey = String
|
||||
@ -144,12 +144,12 @@ keyStr
|
||||
|
||||
data DebugNames =
|
||||
DebugNames
|
||||
{ debugMutePredName :: Ghc.Name
|
||||
, debugDeepPredName :: Ghc.Name
|
||||
, debugDeepKeyPredName :: Ghc.Name
|
||||
, debugPredName :: Ghc.Name
|
||||
, debugKeyPredName :: Ghc.Name
|
||||
, debugInertPredName :: Ghc.Name
|
||||
{ traceMutePredName :: Ghc.Name
|
||||
, traceDeepPredName :: Ghc.Name
|
||||
, traceDeepKeyPredName :: Ghc.Name
|
||||
, tracePredName :: Ghc.Name
|
||||
, traceKeyPredName :: Ghc.Name
|
||||
, traceInertPredName :: Ghc.Name
|
||||
, entryName :: Ghc.Name
|
||||
, debugContextName :: Ghc.Name
|
||||
}
|
||||
|
Loading…
Reference in New Issue
Block a user