patrickaldis/garnet
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Define withConstrained

Browse Source
This commit is contained in:
George Thomas 2026-01-06 17:36:37 +00:00
parent 83e4489e1f
commit cd292d4580
2 changed files with 7 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
haskell/Main.hs
View File

@ -43,7 +43,7 @@ main =
. runParser (parser isRealData <* eof) fp
=<< T.readFile fp
let (rs, os) =
(lookupHList (fst . getCompose) &&& foldHListF ((\(Constrained x) -> HConsC x) . snd . getCompose) HNilC) $
(lookupHList (fst . getCompose) &&& foldHListF (flip withConstrained HConsC . snd . getCompose) HNilC) $
mapHListF (\(Compose (Fanout (f, Op o))) -> Compose $ (o &&& id) $ f input) parts
in pure (input, rs, os)
)

9
haskell/Pre.hs
View File

@ -54,6 +54,7 @@ module Pre (
(/\\),
nil,
Constrained (..),
withConstrained,
Fanout (..),
Length,
TestTree (..),
@ -160,10 +161,10 @@ sortPair (a, b) = if a <= b then (a, b) else (b, a)
type PuzzleParts input = HListF (Compose (Fanout ((->) input) (Op Text)) (Constrained NFData))
infixr 9 /\\
(/\\) :: (NFData output) => (input -> output, output -> Text) -> PuzzleParts input outputs -> PuzzleParts input (output : outputs)
(/\\) (f, o) = HConsF $ Compose $ Fanout (Constrained . f, Op $ o . (.unwrap))
(/\\) (f, o) = HConsF $ Compose $ Fanout (Constrained . f, Op $ flip withConstrained o)
infixr 9 /\
(/\) :: (Show output, NFData output) => (input -> output) -> PuzzleParts input outputs -> PuzzleParts input (output : outputs)
(/\) f = HConsF $ Compose $ Fanout (Constrained . f, Op $ T.show . (.unwrap))
(/\) f = HConsF $ Compose $ Fanout (Constrained . f, Op $ flip withConstrained T.show)
nil :: PuzzleParts input '[]
nil = HNilF
@ -209,7 +210,9 @@ lookupHList f = \case
HConsF x xs -> maybe (f x) (lookupHList f xs) . unshift
data Constrained c a where
Constrained :: (c a) => {unwrap :: a} -> Constrained c a
Constrained :: (c a) => a -> Constrained c a
withConstrained :: Constrained c a -> ((c a) => a -> b) -> b
withConstrained (Constrained x) f = f x
newtype Fanout f g a = Fanout (f a, g a)