algebra-driven-design 0.1.0.1 → 0.1.1.0
raw patch · 18 files changed
+1907/−1734 lines, 18 filesdep +bytestringdep +dlistdep +generic-databinary-added
Dependencies added: bytestring, dlist, generic-data, hashable, monoid-subclasses, monoidal-containers, multiset
Files
- README.md +2/−0
- algebra-driven-design.cabal +21/−6
- src/ADD/Games/Basic.hs +0/−313
- src/ADD/Games/Correct.hs +0/−676
- src/ADD/Tiles/Basic.hs +0/−360
- src/ADD/Tiles/Functor.hs +0/−379
- src/Scavenge/CPS.hs +440/−0
- src/Scavenge/ClueState.hs +38/−0
- src/Scavenge/Initial.hs +380/−0
- src/Scavenge/InputFilter.hs +152/−0
- src/Scavenge/Results.hs +39/−0
- src/Scavenge/Sigs.hs +100/−0
- src/Scavenge/Test.hs +23/−0
- src/Tiles/Efficient.hs +338/−0
- src/Tiles/Initial.hs +374/−0
- static/haskell.png binary
- static/sandy.png binary
- static/spj.png binary
README.md view
@@ -1,1 +1,3 @@ # algebra-driven-design++[](https://hackage.haskell.org/package/algebra-driven-design)
algebra-driven-design.cabal view
@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 83264216f7a4cccd0ae2afd48729bdb568273e6fa01526c48b87bdc0c9698613+-- hash: dd9b7e4ee0192c481374c8af6d85e151a6d20d9d65438db2019bb40253841345 name: algebra-driven-design-version: 0.1.0.1+version: 0.1.1.0 synopsis: Companion library for the book Algebra-Driven Design by Sandy Maguire description: Please see the README on GitHub at <https://github.com/isovector/algebra-driven-design#readme> category: Book@@ -24,6 +24,7 @@ ChangeLog.md static/sandy.png static/haskell.png+ static/spj.png source-repository head type: git@@ -31,20 +32,34 @@ library exposed-modules:- ADD.Games.Basic- ADD.Games.Correct- ADD.Tiles.Basic- ADD.Tiles.Functor+ Scavenge.ClueState+ Scavenge.CPS+ Scavenge.Initial+ Scavenge.InputFilter+ Scavenge.Results+ Scavenge.Sigs+ Scavenge.Test+ Tiles.Efficient+ Tiles.Initial other-modules: Paths_algebra_driven_design hs-source-dirs: src+ default-extensions: ConstraintKinds DeriveGeneric GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase OverloadedStrings RecordWildCards ScopedTypeVariables StandaloneDeriving TupleSections TypeApplications ViewPatterns DerivingStrategies DerivingVia+ ghc-options: -Wall -Wcompat -Widentities -Wincomplete-uni-patterns -Wincomplete-record-updates -Wredundant-constraints -fhide-source-paths -Wpartial-fields -Wmissing-deriving-strategies build-depends: JuicyPixels , QuickCheck , base >=4.7 && <5+ , bytestring , containers+ , dlist , file-embed+ , generic-data+ , hashable+ , monoid-subclasses+ , monoidal-containers , mtl+ , multiset , quickspec default-language: Haskell2010
− src/ADD/Games/Basic.hs
@@ -1,313 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeApplications #-}--module ADD.Games.Basic where--import Data.Data-import Data.Word-import GHC.Generics-import Test.QuickCheck hiding (Result, choose)-import Control.Monad.Writer-import Data.Tuple (swap)-import Data.List-import QuickSpec--data Event = Event Word8- deriving stock (Eq, Ord, Show, Data, Generic)---- # ArbitraryEvent-instance Arbitrary Event where- arbitrary = Event <$> arbitrary- shrink = genericShrink---data EventFilter- = Always- | Never- | Exactly Word8 -- ! 1- deriving stock (Eq, Ord, Show, Data, Generic)---- # ArbitraryEventFilter-instance Arbitrary EventFilter where- arbitrary = frequency- [ (3, pure Always)- , (1, pure Never)- , (5, Exactly <$> arbitrary)- ]- shrink = genericShrink--always :: EventFilter-always = Always--never :: EventFilter-never = Never--sig_filters :: Sig-sig_filters = signature- [ con "always" always- , con "never" never- ]---data Reward = Reward Word8- deriving stock (Eq, Ord, Show, Data, Generic)---- # ArbitraryReward-instance Arbitrary Reward where- arbitrary = Reward <$> arbitrary- shrink = genericShrink---data Result- = Victory- | Defeat- deriving stock (Eq, Ord, Show, Data, Generic)---- # ArbitraryResult-instance Arbitrary Result where- arbitrary = elements [ victory, defeat ]- shrink = genericShrink--victory :: Result-victory = Victory--defeat :: Result-defeat = Defeat--sig_results :: Sig-sig_results = signature- [ con "victory" victory- , con "defeat" defeat- ]------------------------------------------------------------------------------------ constructors---------------------------------------------------------------------------------data Game- = Win- | Lose- | GiveReward Reward- | AndThen Game Game- | Subgame Game Game Game- | EitherG Game Game- | Both Game Game- | Race Game Game- | Choose [(EventFilter, Game)]- deriving stock (Eq, Ord, Show, Data, Generic)---- # ArbitraryGame-instance Arbitrary Game where- arbitrary = sized $ \n ->- case n <= 1 of- True -> elements [win, lose]- False -> frequency- [ (3, pure win)- , (3, pure lose)- , (3, reward <$> arbitrary)- , (5, andThen <$> decayArbitrary 2- <*> decayArbitrary 2)- , (5, subgame <$> decayArbitrary 3- <*> decayArbitrary 3- <*> decayArbitrary 3)- , (5, both <$> decayArbitrary 2- <*> decayArbitrary 2)- , (5, eitherG <$> decayArbitrary 2- <*> decayArbitrary 2)- , (5, race <$> decayArbitrary 2- <*> decayArbitrary 2)- , (5, choose <$> decayArbitrary 5)- , (2, comeback <$> arbitrary)- , (1, pure bottom)- , (5, gate <$> arbitrary <*> arbitrary)- ]- shrink = genericShrink---- # ObserveGame-instance- Observe [Event] ([Reward], Maybe Result) Game- where- observe = runGame--decayArbitrary :: Arbitrary a => Int -> Gen a-decayArbitrary n = scale (`div` n) arbitrary--reward :: Reward -> Game-reward = GiveReward--win :: Game-win = Win--lose :: Game-lose = Lose--andThen :: Game -> Game -> Game-andThen Win _ = win-andThen Lose _ = lose-andThen a b = AndThen a b--subgame :: Game -> Game -> Game -> Game-subgame Win g1 _ = g1-subgame Lose _ g2 = g2-subgame g g1 g2 = Subgame g g1 g2--eitherG :: Game -> Game -> Game-eitherG Lose Lose = lose-eitherG Win _ = win-eitherG _ Win = win-eitherG a b = EitherG a b--both :: Game -> Game -> Game-both Win Win = win-both Lose _ = lose-both _ Lose = lose-both a b = Both a b--race :: Game -> Game -> Game-race Win _ = win-race Lose _ = lose-race _ Win = win-race _ Lose = lose-race a b = Race a b--choose :: [(EventFilter, Game)] -> Game-choose cs = Choose cs--sig_games_core :: Sig-sig_games_core = signature- [ con "win" win- , con "lose" lose- , con "reward" reward- , con "andThen" andThen- , con "subgame" subgame- , con "eitherG" eitherG- , con "both" both- , con "race" race- , con "choose" choose- ]----------------------------------------------------------------------------------- extensions---------------------------------------------------------------------------------comeback :: Game -> Game-comeback g = subgame g lose win--bottom :: Game-bottom = choose []--gate :: EventFilter -> Game -> Game-gate ef g = choose [(ef, g)]--sig_games_ext :: Sig-sig_games_ext = signature- [ con "comeback" comeback- , con "bottom" bottom- , con "gate" gate- ]---bingo :: [[Game]] -> Reward -> Game-bingo squares r- = let subgames = squares- ++ transpose squares -- ! 1- allOf :: [Game] -> Game- allOf = foldr both win- anyOf :: [Game] -> Game- anyOf = foldr eitherG lose- in anyOf (fmap allOf subgames) `andThen` reward r----------------------------------------------------------------------------------- tests---------------------------------------------------------------------------------bingo_game :: Game-bingo_game = flip bingo (Reward 100) $ do- x <- [0..2]- pure $ do- y <- [0..2]- pure $ gate (Exactly $ x * 10 + y) win------------------------------------------------------------------------------------ observations---------------------------------------------------------------------------------runGame :: [Event] -> Game -> ([Reward], Maybe Result)-runGame evs g =- swap $ runWriter $ fmap _toResult $ _runGame g evs--_toResult :: Game -> Maybe Result-_toResult Win = Just Victory-_toResult Lose = Just Defeat-_toResult _ = Nothing--_runGame :: Game -> [Event] -> Writer [Reward] Game-_runGame g (e : es) = do- g' <- _stepGame g (Just e)- _runGame g' es-_runGame g [] = do- g' <- _stepGame g Nothing- case g == g' of -- ! 1- True -> pure g'- False -> _runGame g' []--_stepGame :: Game -> Maybe Event -> Writer [Reward] Game-_stepGame Win _ = pure win-_stepGame Lose _ = pure lose-_stepGame (GiveReward r) _ = tell [r] >> pure win-_stepGame (AndThen g1 g2) e =- andThen <$> _stepGame g1 e- <*> pure g2-_stepGame (Subgame g g1 g2) e = -- ! 1- subgame <$> _stepGame g e -- ! 2- <*> pure g1- <*> pure g2-_stepGame (EitherG g1 g2) e =- eitherG <$> _stepGame g1 e- <*> _stepGame g2 e-_stepGame (Both g1 g2) e =- both <$> _stepGame g1 e- <*> _stepGame g2 e-_stepGame (Race g1 g2) e =- race <$> _stepGame g1 e- <*> _stepGame g2 e-_stepGame (Choose cs) (Just e)- | Just (_, g) <- find (\(ef, _) -> matches ef e) cs- = pure g-_stepGame x@Choose{} _ = pure x---matches :: EventFilter -> Event -> Bool-matches Never _ = False-matches Always _ = True-matches (Exactly e) (Event ev) = e == ev----------------------------------------------------------------------------------- specifications---------------------------------------------------------------------------------sig_types :: Sig-sig_types = signature- [ monoType $ Proxy @Event- , monoType $ Proxy @EventFilter- , monoType $ Proxy @Reward- , monoType $ Proxy @Result- , monoTypeObserve $ Proxy @Game- , vars ["e"] $ Proxy @Event- , vars ["ef"] $ Proxy @EventFilter- , vars ["r"] $ Proxy @Reward- , vars ["res"] $ Proxy @Result- , vars ["g"] $ Proxy @Game- ]--sig_options :: Sig-sig_options = signature- [ withMaxTermSize 5- ]-
− src/ADD/Games/Correct.hs
@@ -1,676 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}--module ADD.Games.Correct where--import Data.Foldable-import qualified Data.Set as S-import Data.Set (Set)-import Data.Data-import Data.Word-import GHC.Generics-import Test.QuickCheck hiding (Result)-import Control.Monad.Writer-import Data.Tuple (swap)-import Data.List-import QuickSpec--data Event = Event Word8- deriving stock (Eq, Ord, Show, Data, Generic)---- # ArbitraryEvent-instance Arbitrary Event where- arbitrary = Event <$> arbitrary- shrink = genericShrink---data EventFilter- = Always- | Never- | Exactly Word8 -- ! 1- deriving stock (Eq, Ord, Show, Data, Generic)---- # ArbitraryEventFilter-instance Arbitrary EventFilter where- arbitrary = frequency- [ (3, pure Always)- , (1, pure Never)- , (5, Exactly <$> arbitrary)- ]- shrink = genericShrink--always :: EventFilter-always = Always--never :: EventFilter-never = Never--sig_filters :: Sig-sig_filters = signature- [ con "always" always- , con "never" never- ]---data Reward = Reward Word8- deriving stock (Eq, Ord, Show, Data, Generic)---- # ArbitraryReward-instance Arbitrary Reward where- arbitrary = Reward <$> arbitrary- shrink = genericShrink---data Result- = Victory- | Defeat- deriving stock (Eq, Ord, Show, Data, Generic)---- # ArbitraryResult-instance Arbitrary Result where- arbitrary = elements [ victory, defeat ]- shrink = genericShrink--victory :: Result-victory = Victory--defeat :: Result-defeat = Defeat--sig_results :: Sig-sig_results = signature- [ con "victory" victory- , con "defeat" defeat- ]------------------------------------------------------------------------------------ constructors---------------------------------------------------------------------------------data Game- = Win- | Lose- | RewardThen Reward Game- | Subgame Game Game Game- | EitherW Game Game- | Both Game Game- | Race Game Game- | Multigate [(EventFilter, Game)]- deriving stock (Eq, Ord, Show, Data, Generic)---- # ArbitraryGame-instance Arbitrary Game where- arbitrary = sized $ \n ->- case n <= 1 of- True -> elements [win, lose]- False -> frequency- [ (3, pure win)- , (3, pure lose)- , (3, reward <$> arbitrary)- , (5, rewardThen <$> arbitrary- <*> decayArbitrary 2)- , (5, andThen <$> decayArbitrary 2- <*> decayArbitrary 2)- , (5, subgame <$> decayArbitrary 3- <*> decayArbitrary 3- <*> decayArbitrary 3)- , (5, both <$> decayArbitrary 2- <*> decayArbitrary 2)- , (5, eitherG <$> decayArbitrary 2- <*> decayArbitrary 2)- , (5, race <$> decayArbitrary 2- <*> decayArbitrary 2)- , (5, multigate <$> decayArbitrary 5)- , (2, comeback <$> arbitrary)- , (1, pure bottom)- , (5, gate <$> arbitrary <*> arbitrary)- ]- shrink = genericShrink---- # ObserveGame-instance- Observe [Event] (Set Reward, Maybe Result) Game- where- observe = runGame--decayArbitrary :: Arbitrary a => Int -> Gen a-decayArbitrary n = scale (`div` n) arbitrary--reward :: Reward -> Game-reward r = rewardThen r win--rewardThen :: Reward -> Game -> Game-rewardThen = RewardThen--win :: Game-win = Win--lose :: Game-lose = Lose--andThen :: Game -> Game -> Game-andThen g1 g2 = subgame g1 g2 lose--subgame :: Game -> Game -> Game -> Game-subgame (RewardThen r g) g1 g2 =- rewardThen r (subgame g g1 g2)-subgame Win g1 _ = g1-subgame Lose _ g2 = g2-subgame g g1 g2 = Subgame g g1 g2--eitherG :: Game -> Game -> Game-eitherG (RewardThen r g1) g2 =- rewardThen r (eitherG g1 g2)-eitherG g1 (RewardThen r g2) =- rewardThen r (eitherG g1 g2)-eitherG Lose Lose = lose-eitherG Win _ = win-eitherG _ Win = win-eitherG a b = EitherW a b--both :: Game -> Game -> Game-both (RewardThen r g1) g2 = rewardThen r (both g1 g2)-both g1 (RewardThen r g2) = rewardThen r (both g1 g2)-both Win Win = win-both Lose _ = lose-both _ Lose = lose-both a b = Both a b--race :: Game -> Game -> Game-race (RewardThen r g1) g2 = rewardThen r (race g1 g2)-race g1 (RewardThen r g2) = rewardThen r (race g1 g2)-race Win _ = win-race Lose _ = lose-race _ Win = win-race _ Lose = lose-race a b = Race a b--multigate :: [(EventFilter, Game)] -> Game-multigate cs = Multigate cs--sig_games_core :: Sig-sig_games_core = signature- [ con "win" win- , con "lose" lose- , con "subgame" subgame- , con "eitherG" eitherG- , con "both" both- , con "race" race- , con "multigate" multigate- , con "rewardThen" rewardThen- , con "gate" gate- ]----------------------------------------------------------------------------------- extensions---------------------------------------------------------------------------------comeback :: Game -> Game-comeback g = subgame g lose win--bottom :: Game-bottom = multigate []--gate :: EventFilter -> Game -> Game-gate ef g = multigate [(ef, g)]--sig_games_ext :: Sig-sig_games_ext = signature- [ con "comeback" comeback- , con "bottom" bottom- , con "andThen" andThen- , con "reward" reward- ]---bingo :: [[Game]] -> Reward -> Game-bingo squares r- = let subgames = squares- ++ transpose squares -- ! 1- allOf :: [Game] -> Game- allOf = foldr both win- anyOf :: [Game] -> Game- anyOf = foldr eitherG lose- in subgame (anyOf (fmap allOf subgames)) (reward r) lose----------------------------------------------------------------------------------- tests---------------------------------------------------------------------------------bingo_game :: Game-bingo_game = flip bingo (Reward 100) $ do- x <- [0..2]- pure $ do- y <- [0..2]- pure $ gate (Exactly $ x * 10 + y) win---foo :: Property-foo = property $ \g g2 -> race g g2 =~= race g2 g----------------------------------------------------------------------------------- observations---------------------------------------------------------------------------------runGame :: [Event] -> Game -> (Set Reward, Maybe Result)-runGame evs g =- swap $ runWriter $ fmap _toResult $ _runGame g evs--_toResult :: Game -> Maybe Result-_toResult Win = Just Victory-_toResult Lose = Just Defeat-_toResult _ = Nothing--_runGame :: Game -> [Event] -> Writer (Set Reward) Game-_runGame g (e : es) = do- g' <- _stepGame g (Just e)- _runGame g' es-_runGame g [] = do- g' <- _stepGame g Nothing- case g == g' of -- ! 1- True -> pure g'- False -> _runGame g' []--_stepGame :: Game -> Maybe Event -> Writer (Set Reward) Game-_stepGame Win _ = pure win-_stepGame Lose _ = pure lose---- # _stepGameRewardThen-_stepGame (RewardThen r g) e =- tell (S.singleton r) >> _stepGame g e--_stepGame (Subgame g g1 g2) e = -- ! 1- subgame <$> _stepGame g e -- ! 2- <*> pure g1- <*> pure g2-_stepGame (EitherW g1 g2) e =- eitherG <$> _stepGame g1 e- <*> _stepGame g2 e-_stepGame (Both g1 g2) e =- both <$> _stepGame g1 e- <*> _stepGame g2 e-_stepGame (Race g1 g2) e =- race <$> _stepGame g1 e- <*> _stepGame g2 e-_stepGame (Multigate cs) (Just e)- | Just (_, g) <- find (\(ef, _) -> matches ef e) cs- = pure g-_stepGame x@Multigate{} _ = pure x---matches :: EventFilter -> Event -> Bool-matches Never _ = False-matches Always _ = True-matches (Exactly e) (Event ev) = e == ev----------------------------------------------------------------------------------- specifications---------------------------------------------------------------------------------sig_types :: Sig-sig_types = signature- [ monoType $ Proxy @Event- , monoType $ Proxy @EventFilter- , monoType $ Proxy @Reward- , monoType $ Proxy @Result- , monoTypeObserve $ Proxy @Game- , vars ["e"] $ Proxy @Event- , vars ["ef"] $ Proxy @EventFilter- , vars ["r"] $ Proxy @Reward- , vars ["res"] $ Proxy @Result- , vars ["g"] $ Proxy @Game- ]--sig_options :: Sig-sig_options = signature- [ withMaxTermSize 5- ]-----quickspec_laws' :: [(String, Property)]-quickspec_laws' =- [ ( "comeback bottom = bottom"- , property $ comeback bottom =~= bottom)- , ( "win = comeback lose"- , property $ win =~= comeback lose)- , ( "lose = comeback win"- , property $ lose =~= comeback win)- , ( "both g g2 = both g2 g"- , property $- \ (g :: Game) (g2 :: Game) ->- both g g2 =~= both g2 g)- , ( "both g g = g"- , property $ \ (g :: Game) -> both g g =~= g)- , ( "eitherG g g2 = eitherG g2 g"- , property $- \ (g :: Game) (g2 :: Game) ->- eitherG g g2 =~= eitherG g2 g)- , ( "eitherG g g = g"- , property $ \ (g :: Game) -> eitherG g g =~= g)- , ( "race g g = g"- , property $ \ (g :: Game) -> race g g =~= g)- , ( "andThen g win = g"- , property $ \ (g :: Game) -> andThen g win =~= g)- , ( "andThen bottom g = bottom"- , property $- \ (g :: Game) -> andThen bottom g =~= bottom)- , ( "andThen lose g = lose"- , property $- \ (g :: Game) -> andThen lose g =~= lose)- , ( "andThen win g = g"- , property $ \ (g :: Game) -> andThen win g =~= g)- , ( "both g bottom = andThen g bottom"- , property $- \ (g :: Game) -> both g bottom =~= andThen g bottom)- , ( "both g win = g"- , property $ \ (g :: Game) -> both g win =~= g)- , ( "eitherG g lose = g"- , property $ \ (g :: Game) -> eitherG g lose =~= g)- , ( "race g bottom = g"- , property $ \ (g :: Game) -> race g bottom =~= g)- , ( "race bottom g = g"- , property $ \ (g :: Game) -> race bottom g =~= g)- , ( "race lose g = both g lose"- , property $- \ (g :: Game) -> race lose g =~= both g lose)- , ( "race win g = eitherG g win"- , property $- \ (g :: Game) -> race win g =~= eitherG g win)- , ( "gate ef bottom = bottom"- , property $- \ (ef :: EventFilter) -> gate ef bottom =~= bottom)- , ( "reward r = rewardThen r win"- , property $- \ (r :: Reward) -> reward r =~= rewardThen r win)- , ( "comeback (comeback g) = g"- , property $- \ (g :: Game) -> comeback (comeback g) =~= g)- , ( "comeback (reward r) = rewardThen r lose"- , property $- \ (r :: Reward) ->- comeback (reward r) =~= rewardThen r lose)- , ( "andThen g g2 = subgame g g2 lose"- , property $- \ (g :: Game) (g2 :: Game) ->- andThen g g2 =~= subgame g g2 lose)- , ( "subgame bottom g g2 = bottom"- , property $- \ (g :: Game) (g2 :: Game) ->- subgame bottom g g2 =~= bottom)- , ( "subgame lose g g2 = g2"- , property $- \ (g :: Game) (g2 :: Game) ->- subgame lose g g2 =~= g2)- , ( "subgame win g g2 = g"- , property $- \ (g :: Game) (g2 :: Game) ->- subgame win g g2 =~= g)- , ( "comeback g = subgame g lose win"- , property $- \ (g :: Game) -> comeback g =~= subgame g lose win)- , ( "subgame g win bottom = eitherG g bottom"- , property $- \ (g :: Game) ->- subgame g win bottom =~= eitherG g bottom)- , ( "andThen (comeback g) g2 = subgame g lose g2"- , property $- \ (g :: Game) (g2 :: Game) ->- andThen (comeback g) g2 =~= subgame g lose g2)- , ( "rewardThen r g = andThen (reward r) g"- , property $- \ (g :: Game) (r :: Reward) ->- rewardThen r g =~= andThen (reward r) g)- , ( "both g (comeback g) = andThen g lose"- , property $- \ (g :: Game) ->- both g (comeback g) =~= andThen g lose)- , ( "rewardThen r g = both g (reward r)"- , property $- \ (g :: Game) (r :: Reward) ->- rewardThen r g =~= both g (reward r))- , ( "eitherG g (comeback g) = subgame g win win"- , property $- \ (g :: Game) ->- eitherG g (comeback g) =~= subgame g win win)- , ( "race g (comeback g) = g"- , property $- \ (g :: Game) -> race g (comeback g) =~= g)- , ( "race (reward r) g = eitherG g (reward r)"- , property $- \ (g :: Game) (r :: Reward) ->- race (reward r) g =~= eitherG g (reward r))- , ( "gate ef (comeback g) = comeback (gate ef g)"- , property $- \ (ef :: EventFilter) (g :: Game) ->- gate ef (comeback g) =~= comeback (gate ef g))- , ( "rewardThen r (comeback g) = comeback (rewardThen r g)"- , property $- \ (g :: Game) (r :: Reward) ->- rewardThen r (comeback g) =~= comeback (rewardThen r g))- , ( "comeback (andThen g bottom) = subgame g bottom win"- , property $- \ (g :: Game) ->- comeback (andThen g bottom) =~= subgame g bottom win)- , ( "comeback (andThen g lose) = subgame g win win"- , property $- \ (g :: Game) ->- comeback (andThen g lose) =~= subgame g win win)- , ( "comeback (both g lose) = eitherG g win"- , property $- \ (g :: Game) ->- comeback (both g lose) =~= eitherG g win)- , ( "comeback (eitherG g bottom) = subgame g lose bottom"- , property $- \ (g :: Game) ->- comeback (eitherG g bottom) =~= subgame g lose bottom)- , ( "both lose (comeback g) = both g lose"- , property $- \ (g :: Game) ->- both lose (comeback g) =~= both g lose)- , ( "both lose (multigate xs) = lose"- , property $- \ (xs :: [(EventFilter, Game)]) ->- both lose (multigate xs) =~= lose)- , ( "race (comeback g) lose = comeback (race g win)"- , property $- \ (g :: Game) ->- race (comeback g) lose =~= comeback (race g win))- , ( "race (multigate xs) lose = lose"- , property $- \ (xs :: [(EventFilter, Game)]) ->- race (multigate xs) lose =~= lose)- , ( "race (multigate xs) win = win"- , property $- \ (xs :: [(EventFilter, Game)]) ->- race (multigate xs) win =~= win)- , ( "andThen (andThen g g2) g3 = andThen g (andThen g2 g3)"- , property $- \ (g :: Game) (g2 :: Game) (g3 :: Game) ->- andThen (andThen g g2) g3 =~= andThen g (andThen g2 g3))- , ( "both (both g g2) g3 = both g (both g2 g3)"- , property $- \ (g :: Game) (g2 :: Game) (g3 :: Game) ->- both (both g g2) g3 =~= both g (both g2 g3))- , ( "eitherG g (andThen g g) = g"- , property $- \ (g :: Game) -> eitherG g (andThen g g) =~= g)- , ( "eitherG g (both g g2) = both g (eitherG g g2)"- , property $- \ (g :: Game) (g2 :: Game) ->- eitherG g (both g g2) =~= both g (eitherG g g2))- , ( "eitherG (eitherG g g2) g3 = eitherG g (eitherG g2 g3)"- , property $- \ (g :: Game) (g2 :: Game) (g3 :: Game) ->- eitherG (eitherG g g2) g3 =~= eitherG g (eitherG g2 g3))- , ( "eitherG g (rewardThen r g2) = eitherG g2 (rewardThen r g)"- , property $- \ (g :: Game) (g2 :: Game) (r :: Reward) ->- eitherG g (rewardThen r g2) =~= eitherG g2 (rewardThen r g))- , ( "race g (andThen g g2) = eitherG g (andThen g g2)"- , property $- \ (g :: Game) (g2 :: Game) ->- race g (andThen g g2) =~= eitherG g (andThen g g2))- , ( "race g (both g g2) = both g (race g g2)"- , property $- \ (g :: Game) (g2 :: Game) ->- race g (both g g2) =~= both g (race g g2))- , ( "race g (eitherG g g2) = eitherG g (race g g2)"- , property $- \ (g :: Game) (g2 :: Game) ->- race g (eitherG g g2) =~= eitherG g (race g g2))- , ( "race g (race g g2) = race g g2"- , property $- \ (g :: Game) (g2 :: Game) ->- race g (race g g2) =~= race g g2)- , ( "race g (race g2 g) = race g g2"- , property $- \ (g :: Game) (g2 :: Game) ->- race g (race g2 g) =~= race g g2)- , ( "race g (rewardThen r g) = rewardThen r g"- , property $- \ (g :: Game) (r :: Reward) ->- race g (rewardThen r g) =~= rewardThen r g)- , ( "race (both g g2) g = both g (race g2 g)"- , property $- \ (g :: Game) (g2 :: Game) ->- race (both g g2) g =~= both g (race g2 g))- , ( "race (eitherG g g2) g = eitherG g (race g2 g)"- , property $- \ (g :: Game) (g2 :: Game) ->- race (eitherG g g2) g =~= eitherG g (race g2 g))- , ( "race (race g g2) g3 = race g (race g2 g3)"- , property $- \ (g :: Game) (g2 :: Game) (g3 :: Game) ->- race (race g g2) g3 =~= race g (race g2 g3))- , ( "race (rewardThen r g) g2 = race g (rewardThen r g2)"- , property $- \ (g :: Game) (g2 :: Game) (r :: Reward) ->- race (rewardThen r g) g2 =~= race g (rewardThen r g2))- , ( "gate ef (andThen g g2) = andThen (gate ef g) g2"- , property $- \ (ef :: EventFilter) (g :: Game) (g2 :: Game) ->- gate ef (andThen g g2) =~= andThen (gate ef g) g2)- , ( "subgame (comeback g) g2 g3 = subgame g g3 g2"- , property $- \ (g :: Game) (g2 :: Game) (g3 :: Game) ->- subgame (comeback g) g2 g3 =~= subgame g g3 g2)- , ( "subgame (reward r) g g2 = rewardThen r g"- , property $- \ (g :: Game) (g2 :: Game) (r :: Reward) ->- subgame (reward r) g g2 =~= rewardThen r g)- , ( "comeback (subgame g g2 win) = andThen g (comeback g2)"- , property $- \ (g :: Game) (g2 :: Game) ->- comeback (subgame g g2 win) =~= andThen g (comeback g2))- , ( "andThen g (both g lose) = andThen g lose"- , property $- \ (g :: Game) ->- andThen g (both g lose) =~= andThen g lose)- , ( "andThen g (eitherG g2 win) = eitherG g (andThen g g2)"- , property $- \ (g :: Game) (g2 :: Game) ->- andThen g (eitherG g2 win) =~= eitherG g (andThen g g2))- , ( "andThen g (race g2 win) = race (andThen g g2) g"- , property $- \ (g :: Game) (g2 :: Game) ->- andThen g (race g2 win) =~= race (andThen g g2) g)- , ( "andThen (eitherG g bottom) g2 = subgame g g2 bottom"- , property $- \ (g :: Game) (g2 :: Game) ->- andThen (eitherG g bottom) g2 =~= subgame g g2 bottom)- , ( "andThen (eitherG g win) g = g"- , property $- \ (g :: Game) -> andThen (eitherG g win) g =~= g)- , ( "andThen (race g g2) lose = andThen (race g2 g) lose"- , property $- \ (g :: Game) (g2 :: Game) ->- andThen (race g g2) lose =~= andThen (race g2 g) lose)- , ( "andThen (race g lose) g = race g lose"- , property $- \ (g :: Game) ->- andThen (race g lose) g =~= race g lose)- , ( "andThen (race g win) g = g"- , property $- \ (g :: Game) -> andThen (race g win) g =~= g)- , ( "both g (eitherG g2 win) = andThen (eitherG g2 win) g"- , property $- \ (g :: Game) (g2 :: Game) ->- both g (eitherG g2 win) =~= andThen (eitherG g2 win) g)- , ( "both lose (eitherG g g2) = both g (both g2 lose)"- , property $- \ (g :: Game) (g2 :: Game) ->- both lose (eitherG g g2) =~= both g (both g2 lose))- , ( "both lose (race g g2) = both g (both g2 lose)"- , property $- \ (g :: Game) (g2 :: Game) ->- both lose (race g g2) =~= both g (both g2 lose))- , ( "both lose (gate ef g) = lose"- , property $- \ (ef :: EventFilter) (g :: Game) ->- both lose (gate ef g) =~= lose)- , ( "both (comeback g) (comeback g2) = comeback (eitherG g g2)"- , property $- \ (g :: Game) (g2 :: Game) ->- both (comeback g) (comeback g2) =~= comeback (eitherG g g2))- , ( "eitherG g (both g2 lose) = andThen (eitherG g2 win) g"- , property $- \ (g :: Game) (g2 :: Game) ->- eitherG g (both g2 lose) =~= andThen (eitherG g2 win) g)- , ( "race g (andThen g2 bottom) = both g (race g g2)"- , property $- \ (g :: Game) (g2 :: Game) ->- race g (andThen g2 bottom) =~= both g (race g g2))- , ( "race g (eitherG g2 bottom) = eitherG g (race g g2)"- , property $- \ (g :: Game) (g2 :: Game) ->- race g (eitherG g2 bottom) =~= eitherG g (race g g2))- , ( "race (comeback g) (comeback g2) = comeback (race g g2)"- , property $- \ (g :: Game) (g2 :: Game) ->- race (comeback g) (comeback g2) =~= comeback (race g g2))- , ( "race (andThen g g) lose = race g lose"- , property $- \ (g :: Game) ->- race (andThen g g) lose =~= race g lose)- , ( "race (andThen g g) win = race g win"- , property $- \ (g :: Game) ->- race (andThen g g) win =~= race g win)- , ( "race (andThen g bottom) g2 = both g2 (race g g2)"- , property $- \ (g :: Game) (g2 :: Game) ->- race (andThen g bottom) g2 =~= both g2 (race g g2))- , ( "race (eitherG g bottom) g2 = eitherG g2 (race g g2)"- , property $- \ (g :: Game) (g2 :: Game) ->- race (eitherG g bottom) g2 =~= eitherG g2 (race g g2))- , ( "race (gate ef g) lose = lose"- , property $- \ (ef :: EventFilter) (g :: Game) ->- race (gate ef g) lose =~= lose)- , ( "race (gate ef g) win = win"- , property $- \ (ef :: EventFilter) (g :: Game) ->- race (gate ef g) win =~= win)- , ( "gate ef (eitherG g bottom) = eitherG bottom (gate ef g)"- , property $- \ (ef :: EventFilter) (g :: Game) ->- gate ef (eitherG g bottom) =~= eitherG bottom (gate ef g))- , ( "subgame g bottom (comeback g2) = comeback (subgame g bottom g2)"- , property $- \ (g :: Game) (g2 :: Game) ->- subgame g bottom (comeback g2) =~= comeback (subgame g bottom g2))- , ( "eitherG bottom (andThen g lose) = subgame g bottom bottom"- , property $- \ (g :: Game) ->- eitherG bottom (andThen g lose) =~= subgame g bottom bottom)- ]-
− src/ADD/Tiles/Basic.hs
@@ -1,360 +0,0 @@-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveLift #-}-{-# LANGUAGE DerivingVia #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE QuantifiedConstraints #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE ViewPatterns #-}--{-# OPTIONS_GHC -Wall #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--module ADD.Tiles.Basic- ( -- * Tiles and their observations- Tile ()- , rasterize- , rasterize'- , toImage-- -- * Tile constructors- , empty- , color- , cw- , ccw- , flipH- , flipV- , beside- , rows- , above- , cols- , behind- , quad- , swirl- , nona-- -- * Special tiles- , haskell- , sandy-- -- * Colors and their observations- , Color- , redChannel- , greenChannel- , blueChannel- , alphaChannel-- -- * Color constructors- , pattern Color- , invert- , mask- , over- ) where--import Codec.Picture.Png-import Codec.Picture.Types-import Control.Applicative hiding (empty)-import Data.Coerce-import Data.FileEmbed-import Data.Functor.Compose-import Data.Word-import Test.QuickCheck hiding (label)-----------------------------------------------------------------------------------type Color = PixelRGBA8--instance Semigroup Color where- (<>) = over--instance Monoid Color where- mempty = Color 0 0 0 0--color :: Double -> Double -> Double -> Double -> Tile-color r g b a = Tile $ const $ const $ _rgba r g b a----------------------------------------------------------------------------------- | Extract the red channel from a 'Color'.-redChannel :: Color -> Double-redChannel (Color r _ _ _) = r----------------------------------------------------------------------------------- | Extract the green channel from a 'Color'.-greenChannel :: Color -> Double-greenChannel (Color _ g _ _) = g----------------------------------------------------------------------------------- | Extract the blue channel from a 'Color'.-blueChannel :: Color -> Double-blueChannel (Color _ _ b _) = b----------------------------------------------------------------------------------- | Extract the alpha channel from a 'Color'.-alphaChannel :: Color -> Double-alphaChannel (Color _ _ _ a) = a----------------------------------------------------------------------------------- | Inverts a 'Color' by negating each of its color channels, but leaving the--- alpha alone.-invert :: Color -> Color-invert (Color r g b a) = Color (1 - r) (1 - g) (1 - b) a---_rgba :: Double -> Double -> Double -> Double -> Color-_rgba r g b a =- PixelRGBA8- (bounded r)- (bounded g)- (bounded b)- (bounded a)- where- bounded :: Double -> Word8- bounded x = round $ x * fromIntegral (maxBound @Word8)----------------------------------------------------------------------------------- |-pattern Color :: Double -> Double -> Double -> Double -> Color-pattern Color r g b a <-- PixelRGBA8- (fromIntegral -> (/255) -> r)- (fromIntegral -> (/255) -> g)- (fromIntegral -> (/255) -> b)- (fromIntegral -> (/255) -> a)- where- Color = _rgba-{-# COMPLETE Color #-}--instance Semigroup Tile where- (<>) = behind--instance Monoid Tile where- mempty = mempty---newtype Tile = Tile- { runTile :: Double -> Double -> Color- }--instance Show Tile where- show _ = "<tile>"--instance Arbitrary Tile where- arbitrary = Tile <$> arbitrary--instance CoArbitrary PixelRGBA8 where- coarbitrary (Color r g b a) = coarbitrary (r, g, b, a)--instance Arbitrary PixelRGBA8 where- arbitrary = PixelRGBA8 <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary----------------------------------------------------------------------------------- | Rotate a 'Tile' clockwise.-cw :: Tile -> Tile-cw (Tile f) = Tile $ \x y -> f y (1 - x)------------------------------------------------------------------------------------ | Rotate a 'Tile' counterclockwise.-ccw :: Tile -> Tile-ccw (Tile f) = Tile $ \x y -> f (1 - y) x--_fromImage :: Image PixelRGBA8 -> Tile-_fromImage img@(Image w h _) = Tile $ \x y ->- pixelAt- img- (max 0 (min (w - 1) (floor $ x * fromIntegral w)))- (max 0 (min (h - 1) (floor $ y * fromIntegral h)))------------------------------------------------------------------------------------ | Place the first 'Tile' to the left of the second. Each 'Tile' will receive--- half of the available width, but keep their full height.-beside :: Tile -> Tile -> Tile-beside (Tile a) (Tile b) = Tile $ \x y ->- case x >= 0.5 of- False -> a (2 * x) y- True -> b (2 * (x - 0.5)) y------------------------------------------------------------------------------------ | Place the first 'Tile' above the second. Each 'Tile' will receive half of--- the available height, but keep their full width.-above :: Tile -> Tile -> Tile-above (Tile a) (Tile b) = Tile $ \x y ->- case y >= 0.5 of- False -> a x (2 * y)- True -> b x (2 * (y - 0.5))------------------------------------------------------------------------------------ | Place the first 'Tile' behind the second. The result of this operation is--- for transparent or semi-transparent pixels in the second argument to be--- blended via 'over' with those in the first.-behind :: Tile -> Tile -> Tile-behind (Tile a) (Tile b) = Tile $ \x y -> flip over (a x y) (b x y)------------------------------------------------------------------------------------ | Mirror a 'Tile' horizontally.-flipH :: Tile -> Tile-flipH (Tile t) = Tile $ \x y ->- t (1 - x) y------------------------------------------------------------------------------------ | Mirror a 'Tile' vertically.-flipV :: Tile -> Tile-flipV (Tile t) = Tile $ \x y ->- t x (1 - y)------------------------------------------------------------------------------------ | The empty, fully transparent 'Tile'.-empty :: Tile-empty = mempty------------------------------------------------------------------------------------ | Like 'above', but repeated. Every element in the list will take up--- a proportional height of the resulting 'Tile'.-rows :: [Tile] -> Tile-rows [] = mempty-rows ts =- let n = length ts- in Tile $ \x y ->- let i = floor $ fromIntegral n * y- in runTile (ts !! i) x y------------------------------------------------------------------------------------ | Like 'beside', but repeated. Every element in the list will take up--- a proportional width of the resulting 'Tile'.-cols :: [Tile] -> Tile-cols [] = mempty-cols ts =- let n = length ts- in Tile $ \x y ->- let i = floor $ fromIntegral n * x- in runTile (ts !! i) x y------------------------------------------------------------------------------------ | Place four 'Tile's in the four quadrants. The first argument is the--- top-left; the second is the top-right; third: bottom left; fourth: bottom--- right.-quad :: Tile -> Tile -> Tile -> Tile -> Tile-quad a b c d = (a `beside` b) `above` (c `beside` d)------------------------------------------------------------------------------------ | A 'quad' where the given 'Tile' is rotated via 'cw' once more per--- quadrant.-swirl :: Tile -> Tile-swirl t = quad t (cw t) (ccw t) $ cw $ cw t------------------------------------------------------------------------------------ | Puts a frame around a 'Tile'. The first argument is the straight-edge--- border for the top of the frame. The second argument should be for the--- top-right corner. The third argument is the 'Tile' that should be framed.-nona :: Tile -> Tile -> Tile -> Tile-nona t tr c =- rows [ cols [ ccw tr, t, tr ]- , cols [ ccw t, c, cw t ]- , cols [ cw (cw tr), cw $ cw t, cw tr ]- ]----------------------------------------------------------------------------------- | Blends a 'Color' using standard alpha compositing.-over :: Color -> Color -> Color-over (PixelRGBA8 r1 g1 b1 a1) (PixelRGBA8 r2 g2 b2 a2) =- let aa = norm a1- ab = norm a2- a' = aa + ab * (1 - aa)- norm :: Word8 -> Double- norm x = fromIntegral x / 255- unnorm :: Double -> Word8- unnorm x = round $ x * 255- f :: Word8 -> Word8 -> Word8- f a b = unnorm $ (norm a * aa + norm b * ab * (1 - aa)) / a'- in- PixelRGBA8 (f r1 r2) (f g1 g2) (f b1 b2) (unnorm a')------------------------------------------------------------------------------------ | Copy the alpha channel from the first 'Color' and the color channels from--- the second 'Color'.-mask :: Color -> Color -> Color-mask (PixelRGBA8 _ _ _ a) (PixelRGBA8 r g b _) = PixelRGBA8 r g b a---------------------------------------------------------------------------------------------------------------------------------------------------------------------- | Like 'rasterize', but into a format that can be directly saved to disk as--- an image.-toImage- :: Int -- ^ resulting width- -> Int -- ^ resulting height- -> Tile- -> Image PixelRGBA8-toImage w h (Tile t) = generateImage f w h- where- coord :: Int -> Int -> Double- coord dx x = fromIntegral dx / fromIntegral x- f :: Int -> Int -> PixelRGBA8- f x y = t (coord x w) (coord y h)------------------------------------------------------------------------------------ | The Haskell logo.-haskell :: Tile-haskell =- let Right (ImageRGBA8 img) = decodePng $(embedFile "static/haskell.png")- in _fromImage img----------------------------------------------------------------------------------- | Sandy.-sandy :: Tile-sandy =- let Right (ImageRGBA8 img) = decodePng $(embedFile "static/sandy.png")- in _fromImage img------------------------------------------------------------------------------------ | Rasterize a 'Tile' down into a row-major representation of its constituent--- "pixels". For a version that emits a list of lists directly, see 'rasterize''.-rasterize- :: Int -- ^ resulting width- -> Int -- ^ resulting heigeht- -> Tile- -> Compose ZipList ZipList Color -- ^ the resulting "pixels" in row-major order-rasterize w h (Tile t) = coerce $ do- y <- [0 .. (h - 1)]- pure $ do- x <- [0 .. (w - 1)]- pure $ f x y-- where- coord :: Int -> Int -> Double- coord dx x = fromIntegral dx / fromIntegral x-- f :: Int -> Int -> Color- f x y = t (coord x w) (coord y h)----------------------------------------------------------------------------------- | Like 'rasterize', but with a more convenient output type.-rasterize'- :: Int -- ^ resulting width- -> Int -- ^ resulting heigeht- -> Tile- -> [[Color]] -- ^ the resulting "pixels" in row-major order-rasterize' w h t = coerce $ rasterize w h t-
− src/ADD/Tiles/Functor.hs
@@ -1,379 +0,0 @@-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveLift #-}-{-# LANGUAGE DerivingVia #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE QuantifiedConstraints #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE ViewPatterns #-}--{-# OPTIONS_GHC -Wall #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--module ADD.Tiles.Functor- ( -- * Tiles and their observations- Tile ()- , rasterize- , rasterize'- , toImage-- -- * Tile constructors- , empty- , color- , cw- , ccw- , flipH- , flipV- , beside- , rows- , above- , cols- , behind- , quad- , quads- , swirl- , nona-- -- * Special tiles- , haskell- , sandy-- -- * Colors and their observations- , Color- , redChannel- , greenChannel- , blueChannel- , alphaChannel-- -- * Color constructors- , pattern Color- , invert- , mask- , over- ) where--import Codec.Picture.Png-import Codec.Picture.Types-import Control.Applicative hiding (empty)-import Data.Coerce-import Data.FileEmbed-import Data.Functor.Compose-import Data.Word-import Test.QuickCheck hiding (label)-----------------------------------------------------------------------------------type Color = PixelRGBA8--instance Semigroup Color where- (<>) = over--instance Monoid Color where- mempty = Color 0 0 0 0--color :: Double -> Double -> Double -> Double -> Tile Color-color r g b a = pure $ _rgba r g b a----------------------------------------------------------------------------------- | Extract the red channel from a 'Color'.-redChannel :: Color -> Double-redChannel (Color r _ _ _) = r----------------------------------------------------------------------------------- | Extract the green channel from a 'Color'.-greenChannel :: Color -> Double-greenChannel (Color _ g _ _) = g----------------------------------------------------------------------------------- | Extract the blue channel from a 'Color'.-blueChannel :: Color -> Double-blueChannel (Color _ _ b _) = b----------------------------------------------------------------------------------- | Extract the alpha channel from a 'Color'.-alphaChannel :: Color -> Double-alphaChannel (Color _ _ _ a) = a----------------------------------------------------------------------------------- | Inverts a 'Color' by negating each of its color channels, but leaving the--- alpha alone.-invert :: Color -> Color-invert (Color r g b a) = Color (1 - r) (1 - g) (1 - b) a---_rgba :: Double -> Double -> Double -> Double -> Color-_rgba r g b a =- PixelRGBA8- (bounded r)- (bounded g)- (bounded b)- (bounded a)- where- bounded :: Double -> Word8- bounded x = round $ x * fromIntegral (maxBound @Word8)----------------------------------------------------------------------------------- |-pattern Color :: Double -> Double -> Double -> Double -> Color-pattern Color r g b a <-- PixelRGBA8- (fromIntegral -> (/255) -> r)- (fromIntegral -> (/255) -> g)- (fromIntegral -> (/255) -> b)- (fromIntegral -> (/255) -> a)- where- Color = _rgba-{-# COMPLETE Color #-}--instance Semigroup a => Semigroup (Tile a) where- (<>) = liftA2 (<>)--instance Monoid a => Monoid (Tile a) where- mempty = pure mempty---newtype Tile a = Tile- { runTile :: Double -> Double -> a- }- deriving stock (Functor)- deriving Applicative via (Compose ((->) Double) ((->) Double))--instance Show (Tile t) where- show _ = "<tile>"--instance Arbitrary a => Arbitrary (Tile a) where- arbitrary = Tile <$> arbitrary--instance CoArbitrary PixelRGBA8 where- coarbitrary (Color r g b a) = coarbitrary (r, g, b, a)--instance Arbitrary PixelRGBA8 where- arbitrary = PixelRGBA8 <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary--instance Monad Tile where- Tile ma >>= f = Tile $ \x y -> runTile (f (ma x y)) x y----------------------------------------------------------------------------------- | Rotate a 'Tile' clockwise.-cw :: Tile a -> Tile a-cw (Tile f) = Tile $ \x y -> f y (1 - x)------------------------------------------------------------------------------------ | Rotate a 'Tile' counterclockwise.-ccw :: Tile a -> Tile a-ccw (Tile f) = Tile $ \x y -> f (1 - y) x--_fromImage :: Image PixelRGBA8 -> Tile Color-_fromImage img@(Image w h _) = Tile $ \x y ->- pixelAt- img- (max 0 (min (w - 1) (floor $ x * fromIntegral w)))- (max 0 (min (h - 1) (floor $ y * fromIntegral h)))------------------------------------------------------------------------------------ | Place the first 'Tile' to the left of the second. Each 'Tile' will receive--- half of the available width, but keep their full height.-beside :: Tile a -> Tile a -> Tile a-beside (Tile a) (Tile b) = Tile $ \x y ->- case x >= 0.5 of- False -> a (2 * x) y- True -> b (2 * (x - 0.5)) y------------------------------------------------------------------------------------ | Place the first 'Tile' above the second. Each 'Tile' will receive half of--- the available height, but keep their full width.-above :: Tile a -> Tile a -> Tile a-above (Tile a) (Tile b) = Tile $ \x y ->- case y >= 0.5 of- False -> a x (2 * y)- True -> b x (2 * (y - 0.5))------------------------------------------------------------------------------------ | Place the first 'Tile' behind the second. The result of this operation is--- for transparent or semi-transparent pixels in the second argument to be--- blended via 'over' with those in the first.-behind :: Tile Color -> Tile Color -> Tile Color-behind = flip (liftA2 over)------------------------------------------------------------------------------------ | Mirror a 'Tile' horizontally.-flipH :: Tile a -> Tile a-flipH (Tile t) = Tile $ \x y ->- t (1 - x) y------------------------------------------------------------------------------------ | Mirror a 'Tile' vertically.-flipV :: Tile a -> Tile a-flipV (Tile t) = Tile $ \x y ->- t x (1 - y)------------------------------------------------------------------------------------ | The empty, fully transparent 'Tile'.-empty :: Tile Color-empty = pure mempty------------------------------------------------------------------------------------ | Like 'above', but repeated. Every element in the list will take up--- a proportional height of the resulting 'Tile'.-rows :: Monoid a => [Tile a] -> Tile a-rows [] = mempty-rows ts =- let n = length ts- in Tile $ \x y ->- let i = floor $ fromIntegral n * y- in runTile (ts !! i) x y------------------------------------------------------------------------------------ | Like 'beside', but repeated. Every element in the list will take up--- a proportional width of the resulting 'Tile'.-cols :: Monoid a => [Tile a] -> Tile a-cols [] = mempty-cols ts =- let n = length ts- in Tile $ \x y ->- let i = floor $ fromIntegral n * x- in runTile (ts !! i) x y------------------------------------------------------------------------------------ | Place four 'Tile's in the four quadrants. The first argument is the--- top-left; the second is the top-right; third: bottom left; fourth: bottom--- right.-quad :: Tile a -> Tile a -> Tile a -> Tile a -> Tile a-quad a b c d = (a `beside` b) `above` (c `beside` d)----------------------------------------------------------------------------------- | Like `quad`, but constructs a 'Tile' of endomorphisms. The given function--- is called one more time for each quadrant, starting clockwise from the--- top-left.-quads :: (a -> a) -> Tile (a -> a)-quads f =- quad- (pure id)- (pure f)- (pure $ f . f . f)- (pure $ f . f)------------------------------------------------------------------------------------ | A 'quad' where the given 'Tile' is rotated via 'cw' once more per--- quadrant.-swirl :: Tile a -> Tile a-swirl t = quad t (cw t) (ccw t) $ cw $ cw t------------------------------------------------------------------------------------ | Puts a frame around a 'Tile'. The first argument is the straight-edge--- border for the top of the frame. The second argument should be for the--- top-right corner. The third argument is the 'Tile' that should be framed.-nona :: Monoid a => Tile a -> Tile a -> Tile a -> Tile a-nona t tr c =- rows [ cols [ ccw tr, t, tr ]- , cols [ ccw t, c, cw t ]- , cols [ cw (cw tr), cw $ cw t, cw tr ]- ]----------------------------------------------------------------------------------- | Blends a 'Color' using standard alpha compositing.-over :: Color -> Color -> Color-over (PixelRGBA8 r1 g1 b1 a1) (PixelRGBA8 r2 g2 b2 a2) =- let aa = norm a1- ab = norm a2- a' = aa + ab * (1 - aa)- norm :: Word8 -> Double- norm x = fromIntegral x / 255- unnorm :: Double -> Word8- unnorm x = round $ x * 255- f :: Word8 -> Word8 -> Word8- f a b = unnorm $ (norm a * aa + norm b * ab * (1 - aa)) / a'- in- PixelRGBA8 (f r1 r2) (f g1 g2) (f b1 b2) (unnorm a')------------------------------------------------------------------------------------ | Copy the alpha channel from the first 'Color' and the color channels from--- the second 'Color'.-mask :: Color -> Color -> Color-mask (PixelRGBA8 _ _ _ a) (PixelRGBA8 r g b _) = PixelRGBA8 r g b a---------------------------------------------------------------------------------------------------------------------------------------------------------------------- | Like 'rasterize', but into a format that can be directly saved to disk as--- an image.-toImage- :: Int -- ^ resulting width- -> Int -- ^ resulting height- -> Tile Color- -> Image PixelRGBA8-toImage w h (Tile t) = generateImage f w h- where- coord :: Int -> Int -> Double- coord dx x = fromIntegral dx / fromIntegral x- f :: Int -> Int -> PixelRGBA8- f x y = t (coord x w) (coord y h)------------------------------------------------------------------------------------ | The Haskell logo.-haskell :: Tile Color-haskell =- let Right (ImageRGBA8 img) = decodePng $(embedFile "static/haskell.png")- in _fromImage img----------------------------------------------------------------------------------- | Sandy.-sandy :: Tile Color-sandy =- let Right (ImageRGBA8 img) = decodePng $(embedFile "static/sandy.png")- in _fromImage img------------------------------------------------------------------------------------ | Rasterize a 'Tile' down into a row-major representation of its constituent--- "pixels". For a version that emits a list of lists directly, see 'rasterize''.-rasterize- :: forall a- . Int -- ^ resulting width- -> Int -- ^ resulting heigeht- -> Tile a- -> Compose ZipList ZipList a -- ^ the resulting "pixels" in row-major order-rasterize w h (Tile t) = coerce $ do- y <- [0 .. (h - 1)]- pure $ do- x <- [0 .. (w - 1)]- pure $ f x y-- where- coord :: Int -> Int -> Double- coord dx x = fromIntegral dx / fromIntegral x-- f :: Int -> Int -> a- f x y = t (coord x w) (coord y h)----------------------------------------------------------------------------------- | Like 'rasterize', but with a more convenient output type.-rasterize'- :: Int -- ^ resulting width- -> Int -- ^ resulting heigeht- -> Tile a- -> [[a]] -- ^ the resulting "pixels" in row-major order-rasterize' w h t = coerce $ rasterize w h t-
+ src/Scavenge/CPS.hs view
@@ -0,0 +1,440 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoOverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE StrictData #-}++{-# OPTIONS_GHC -funbox-strict-fields #-}+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}++module Scavenge.CPS+ ( -- * Observations+ runChallenge+ , getClues+ , getRewards++ -- * Challenges+ , empty+ , reward+ , clue+ , andThen+ , both+ , eitherC+ , bottom+ , gate++ -- * Input filters+ , always+ , never+ , andF+ , orF+ , notF+ , custom+ , HasFilter (..)++ -- * Clue states+ , seen+ , completed+ , failed++ -- * Laws+ , quickspec_laws++ -- * Types+ , Challenge ()+ , MonoidalMap ()+ , Results ()+ , ClueState ()+ ) where++import Control.Applicative (liftA2)+import Control.Monad.ST+import Data.DList (DList)+import qualified Data.DList as DL+import Data.Foldable+import Data.Map.Monoidal (MonoidalMap)+import qualified Data.Map.Monoidal as M+import Data.Monoid+import Data.Monoid.Cancellative+import Data.MultiSet (MultiSet)+import Data.STRef+import Data.Set (Set)+import qualified Data.Set as S+import GHC.Generics+import Generic.Data+import QuickSpec+import Scavenge.ClueState+import Scavenge.InputFilter+import Scavenge.Results+import Scavenge.Test ()+import Test.QuickCheck hiding (Result, choose)++newtype Challenge i k r = Challenge+ { unChallenge+ :: forall s -- ! 1+ . DList k -- kctx+ -> (DList k -> ClueState+ -> ST s ClueState)+ -> ST s (ChallengeData i k r s)+ -> ST s (ChallengeData i k r s)+ }++instance ( Show (CustomFilter i), Ord (CustomFilter i)+ , Ord k, Show k+ , Monoid r, Show r+ )+ => Show (Challenge i k r) where+ show (Challenge g) =+ runST $ fmap show $ g mempty (const $ pure . id) end++-- # ArbitraryChallenge+instance+ ( Arbitrary (CustomFilter i), Ord (CustomFilter i)+ , Arbitrary k, Ord k+ , Monoid r, Commutative r, Arbitrary r, Eq r+ ) => Arbitrary (Challenge i k r) where+ arbitrary = sized $ \n ->+ case n <= 1 of+ True -> pure empty+ False -> frequency+ [ (3, pure empty)+ , (3, reward <$> arbitrary)+ , (3, clue <$> arbitrary <*> arbitrary)+ , (5, andThen <$> decayArbitrary 2+ <*> decayArbitrary 2)+ , (5, both <$> decayArbitrary 2+ <*> decayArbitrary 2)+ , (5, eitherC <$> decayArbitrary 2+ <*> decayArbitrary 2)+ , (5, gate <$> arbitrary <*> arbitrary)+ , (2, pure bottom)+ ]++-- # ObserveChallenge+instance+ ( HasFilter i, Arbitrary i, Ord (CustomFilter i)+ , Ord k+ , Monoid r, Ord r+ ) => Observe [i]+ (Results k r, Bool)+ (Challenge i k r) where+ observe = runChallenge++-- # SemigroupChallenge+instance (Semigroup r, Ord k, Ord (CustomFilter i))+ => Semigroup (Challenge i k r) where+ Challenge c1 <> Challenge c2 =+ Challenge $ \kctx rec cont -> do+ d1 <- c1 kctx rec cont+ d2 <- c2 kctx rec cont+ pure $ d1 <> d2+ {-# INLINABLE (<>) #-}++-- # MonoidChallenge+instance (Monoid r, Ord k, Ord (CustomFilter i))+ => Monoid (Challenge i k r) where+ mempty = Challenge $ \_ -> pure mempty+++data ChallengeData i k r s = ChallengeData+ { waitingOn+ :: !(MonoidalMap+ (InputFilter i)+ (ST s (ChallengeData i k r s)))+ , results :: !(Results k r)+ , isComplete :: !Any+ }+ deriving stock (Generic)+++-- # SemigroupCData+deriving via Generically (ChallengeData i k r s)+ instance (Ord k, Semigroup r, Ord (CustomFilter i))+ => Semigroup (ChallengeData i k r s)++-- # MonoidCData+deriving via Generically (ChallengeData i k r s)+ instance (Ord k, Monoid r, Ord (CustomFilter i))+ => Monoid (ChallengeData i k r s)++instance (Show k, Show (CustomFilter i), Show r)+ => Show (ChallengeData i k r s) where+ show (ChallengeData ri r (Any res)) = mconcat+ [ "Challenge { waitingFor = "+ , show $ M.keys ri+ , ", result = "+ , show res+ , ", rewards = "+ , show r+ , " }"+ ]++empty :: Challenge i k r+empty = Challenge $ \_ _ cont -> cont++reward+ :: forall i k r+ . ( Ord k, Ord (CustomFilter i)+ , Commutative r, Monoid r+ )+ => r+ -> Challenge i k r+reward r = rewardThen r empty++tellClue+ :: (Ord (CustomFilter i), Ord k, Monoid r)+ => MonoidalMap [k] ClueState+ -> ChallengeData i k r s+tellClue ks =+ mempty { results = Results mempty ks }++tellReward+ :: (Ord (CustomFilter i), Ord k, Monoid r)+ => r+ -> ChallengeData i k r s+tellReward r = mempty { results = Results r mempty }++clue+ :: forall i k r+ . (Ord (CustomFilter i), Ord k, Monoid r)+ => [k]+ -> Challenge i k r+ -> Challenge i k r+clue [] c = c+clue (k : ks) c = -- ! 1+ Challenge $ \kctx rec cont -> do+ let kctx' = kctx <> DL.singleton k+ k' = DL.toList kctx'+ state <- rec kctx' seen -- ! 2+ d <- unChallenge (clue ks c) kctx' rec $ do -- ! 3+ dc <- cont+ pure $ tellClue (M.singleton k' completed) <> dc+ pure $ tellClue (M.singleton k' state) <> d++rewardThen+ :: forall i k r+ . (Ord (CustomFilter i), Ord k, Monoid r, Ord k)+ => r+ -> Challenge i k r+ -> Challenge i k r+rewardThen r (Challenge c) =+ Challenge $ \kctx rec cont -> do+ d <- c kctx rec cont+ pure $ tellReward r <> d+++eitherC+ :: forall i k r+ . (Ord (CustomFilter i), Ord k, Monoid r)+ => Challenge i k r+ -> Challenge i k r+ -> Challenge i k r+eitherC (Challenge c1) (Challenge c2) =+ Challenge $ \kctx rec cont -> do+ filled <- newSTRef False -- ! 1+ c1_clues <- newSTRef mempty -- ! 2+ c2_clues <- newSTRef mempty+ d1 <-+ c1 kctx (decorate filled c1_clues rec) $ -- ! 3+ oneshot filled $ do+ d <- cont+ p <- prune c2_clues -- ! 4+ pure $ d <> p+ d2 <-+ c2 kctx (decorate filled c2_clues rec) $+ oneshot filled $ do+ d <- cont+ p <- prune c1_clues+ pure $ d <> p+ pure $ d1 <> d2+++decorate+ :: Ord k+ => STRef s Bool+ -> STRef s (Set (DList k))+ -> (DList k -> ClueState -> ST s ClueState)+ -> DList k+ -> ClueState+ -> ST s ClueState+decorate filled ref rec k cs = do+ readSTRef filled >>= \case -- ! 1+ True -> rec k failed -- ! 2+ False -> do+ modifySTRef' ref $ S.insert k -- ! 3+ rec k cs+++prune+ :: (Ord (CustomFilter i), Ord k, Monoid r)+ => STRef s (Set (DList k))+ -> ST s (ChallengeData i k r s)+prune ref = do+ ks <- readSTRef ref+ pure $ flip foldMap ks $ \k ->+ tellClue $ M.singleton (DL.toList k) failed+++oneshot :: Monoid a => STRef s Bool -> ST s a -> ST s a+oneshot ref m =+ readSTRef ref >>= \case+ True -> pure mempty+ False -> do+ writeSTRef ref True+ m+++andThen+ :: Challenge i k r+ -> Challenge i k r+ -> Challenge i k r+andThen (Challenge c1) (Challenge c2) =+ Challenge $ \kctx rec cont ->+ c1 kctx rec (c2 kctx rec cont)++both+ :: forall i k r+ . (Ord (CustomFilter i), Ord k, Monoid r)+ => Challenge i k r+ -> Challenge i k r+ -> Challenge i k r+both (Challenge c1) (Challenge c2) =+ Challenge $ \kctx rec cont -> do+ remaining_wins <- newSTRef @Int 2 -- ! 1+ let run_win = do -- ! 2+ modifySTRef' remaining_wins $ subtract 1+ readSTRef remaining_wins >>= \case+ 0 -> cont+ _ -> pure mempty+ liftA2 (<>)+ (c1 kctx rec run_win) -- ! 3+ (c2 kctx rec run_win)++gate+ :: forall i k r+ . (Ord (CustomFilter i), Ord k, Monoid r)+ => InputFilter i+ -> Challenge i k r+ -> Challenge i k r+gate ef (Challenge c) = Challenge $ \kctx rec cont ->+ pure $ (mempty @(ChallengeData i k r _))+ { waitingOn = M.singleton ef $ c kctx rec cont }+++bottom+ :: forall i k r+ . (Ord (CustomFilter i), Ord k, Monoid r)+ => Challenge i k r+bottom = Challenge $ \_ -> mempty++end+ :: (Ord (CustomFilter i), Ord k, Monoid r)+ => ST s (ChallengeData i k r s)+end = pure $ mempty { isComplete = Any True }++runChallenge+ :: forall i k r+ . ( HasFilter i, Ord (CustomFilter i)+ , Ord k+ , Monoid r+ )+ => [i] -> Challenge i k r -> (Results k r, Bool)+runChallenge evs (Challenge c) = runST $ do+ d' <-+ pumpChallenge evs =<<+ c mempty -- ! 1+ (const $ pure . id) -- ! 2+ end -- ! 3+ pure (results d', getAny $ isComplete d')+++pumpChallenge+ :: ( HasFilter i, Ord (CustomFilter i)+ , Ord k+ , Monoid r+ )+ => [i]+ -> ChallengeData i k r s+ -> ST s (ChallengeData i k r s)+pumpChallenge [] d = pure d+pumpChallenge _ d+ | getAny $ isComplete d -- ! 1+ = pure d+pumpChallenge (ri : es) d =+ pumpChallenge es =<< step ri d++getClues+ :: forall i k r.+ ( HasFilter i, Ord (CustomFilter i)+ , Ord k+ , Monoid r+ )+ => Challenge i k r+ -> [i]+ -> MonoidalMap [k] ClueState+getClues c = clues . fst . flip runChallenge c++getRewards+ :: forall i k r.+ ( HasFilter i, Ord (CustomFilter i)+ , Ord k+ , Monoid r+ )+ => Challenge i k r+ -> [i]+ -> r+getRewards c = rewards . fst . flip runChallenge c+++step+ :: forall i k r s.+ ( HasFilter i, Ord (CustomFilter i)+ , Ord k+ , Monoid r+ )+ => i+ -> ChallengeData i k r s+ -> ST s (ChallengeData i k r s)+step ri d = do+ let efs = M.assocs $ waitingOn d -- ! 1+ (endo, ds) <-+ flip foldMapM efs $ \(ef, res) -> -- ! 2+ case matches ef ri of -- ! 3+ True -> do+ d' <- res -- ! 4+ pure (Endo $ M.delete ef, d') -- ! 5+ False -> mempty+ pure $+ d { waitingOn =+ appEndo endo $ waitingOn d -- ! 6+ } <> ds -- ! 7++foldMapM+ :: (Monoid m, Applicative f, Traversable t)+ => (a -> f m)+ -> t a+ -> f m+foldMapM f = fmap fold . traverse f++#include "spec.inc"++{-# INLINABLE empty #-}+{-# INLINABLE reward #-}+{-# INLINABLE tellClue #-}+{-# INLINABLE tellReward #-}+{-# INLINABLE clue #-}+{-# INLINABLE rewardThen #-}+{-# INLINABLE eitherC #-}+{-# INLINABLE decorate #-}+{-# INLINABLE prune #-}+{-# INLINABLE oneshot #-}+{-# INLINABLE andThen #-}+{-# INLINABLE both #-}+{-# INLINABLE gate #-}+{-# INLINABLE bottom #-}+
+ src/Scavenge/ClueState.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE MultiParamTypeClasses #-}++module Scavenge.ClueState where++import Test.QuickCheck+import QuickSpec+import Data.Semigroup++data ClueState+ = Seen | Failed | Completed -- ! 1+ deriving stock (Eq, Ord, Show, Enum, Bounded)+ deriving (Semigroup, Monoid) via Max ClueState -- ! 2++instance Observe () ClueState ClueState++instance Arbitrary ClueState where+ arbitrary = elements $ enumFromTo minBound maxBound++seen :: ClueState+seen = Seen++completed :: ClueState+completed = Completed++failed :: ClueState+failed = Failed++------------------------------------------------------------------------------++sig_cluestate :: Sig+sig_cluestate = signature+ [ con "seen" $ seen+ , con "completed" $ completed+ , con "failed" $ failed+ , con "<>" $ (<>) @ClueState+ , mono @ClueState+ ]+
+ src/Scavenge/Initial.hs view
@@ -0,0 +1,380 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}++module Scavenge.Initial+ ( -- * Observations+ runChallenge+ , getClues+ , getRewards++ -- * Challenges+ , empty+ , reward+ , clue+ , andThen+ , both+ , eitherC+ , bottom+ , gate++ -- * Input filters+ , always+ , never+ , andF+ , orF+ , notF+ , custom+ , HasFilter (..)++ -- * Clue states+ , seen+ , completed+ , failed++ -- * Laws+ , quickspec_laws++ -- * Types+ , Challenge ()+ , MonoidalMap ()+ , Results ()+ , ClueState ()+ ) where++import Control.Monad+import Control.Monad.Writer.Class+import Data.Map.Monoidal (MonoidalMap, singleton)+import Data.Semigroup.Cancellative+import GHC.Generics+import Data.MultiSet (MultiSet)+import QuickSpec+import Scavenge.ClueState+import Scavenge.InputFilter+import Scavenge.Results+import Scavenge.Test ()+import Test.QuickCheck hiding (within)+++------------------------------------------------------------------------------++data Challenge i k r+ = Empty+ | Gate (InputFilter i) (Challenge i k r)+ | Clue k (Challenge i k r)+ | RewardThen r (Challenge i k r)+ | EitherC (Challenge i k r) (Challenge i k r)+ | Both (Challenge i k r) (Challenge i k r)+ | AndThen (Challenge i k r) (Challenge i k r)+ deriving stock (Generic)++deriving stock instance+ (Eq r, Eq k, Eq (CustomFilter i))+ => Eq (Challenge i k r)++deriving stock instance+ (Show r, Show k, Show (CustomFilter i))+ => Show (Challenge i k r)++-- # ArbitraryChallenge+instance+ ( Arbitrary (CustomFilter i)+ , Arbitrary k+ , Monoid r, Commutative r, Arbitrary r, Eq r+ ) => Arbitrary (Challenge i k r) where+ arbitrary = sized $ \n ->+ case n <= 1 of+ True -> pure empty+ False -> frequency+ [ (3, pure empty)+ , (3, reward <$> arbitrary)+ , (3, clue <$> resize 4 arbitrary <*> arbitrary)+ , (5, andThen <$> decayArbitrary 2+ <*> decayArbitrary 2)+ , (5, both <$> decayArbitrary 2+ <*> decayArbitrary 2)+ , (5, eitherC <$> decayArbitrary 2+ <*> decayArbitrary 2)+ , (5, gate <$> arbitrary <*> arbitrary)+ , (2, pure bottom)+ ]++ shrink Empty = []+ shrink x = Empty : filter isValid (genericShrink x)++-- # ObserveChallenge+instance+ ( HasFilter i, Arbitrary i, Eq (CustomFilter i)+ , Ord k+ , Commutative r, Monoid r, Ord r+ ) => Observe [i]+ (Results k r, Bool)+ (Challenge i k r) where+ observe = flip runChallenge++------------------------------------------------------------------------------+++findClues+ :: forall i k r+ . Ord k+ => [k]+ -> Challenge i k r+ -> MonoidalMap [k] ClueState+findClues _ Empty+ = mempty+findClues kctx (Both c1 c2)+ = findClues kctx c1 <> findClues kctx c2+findClues kctx (EitherC c1 c2)+ = findClues kctx c1 <> findClues kctx c2+findClues _ (Gate _ _)+ = mempty+findClues kctx (AndThen c _)+ = findClues kctx c+findClues kctx (RewardThen _ c)+ = findClues kctx c+findClues kctx (Clue k Empty)+ = singleton (kctx <> [k]) completed+findClues kctx (Clue k c)+ = singleton (kctx <> [k]) seen+ <> findClues (kctx <> [k]) c++pumpChallenge+ :: forall i k r+ . ( Ord k+ , HasFilter i+ , Monoid r, Commutative r, Eq r+ )+ => Challenge i k r+ -> [i]+ -> (Results k r, Challenge i k r)+pumpChallenge c+ = foldM (flip $ step []) c+ . (Nothing :)+ . fmap Just++runChallenge+ :: forall i k r.+ ( HasFilter i, Eq (CustomFilter i)+ , Ord k+ , Monoid r, Commutative r, Eq r+ )+ => Challenge i k r+ -> [i]+ -> (Results k r, Bool)+runChallenge c = fmap (== Empty) . pumpChallenge c++getRewards+ :: forall i k r.+ ( HasFilter i+ , Ord k+ , Monoid r, Commutative r, Eq r+ ) =>+ Challenge i k r -> [i] -> r+getRewards c = rewards . fst . pumpChallenge c++getClues+ :: forall i k r.+ ( HasFilter i+ , Ord k+ , Monoid r, Commutative r, Eq r+ )+ => Challenge i k r+ -> [i]+ -> MonoidalMap [k] ClueState+getClues c = clues . fst . pumpChallenge c+++isEmpty+ :: forall i k r.+ ( HasFilter i, Eq (CustomFilter i)+ , Ord k+ , Monoid r, Commutative r, Eq r+ )+ => Challenge i k r+ -> Bool+isEmpty = (== Empty) . snd . flip pumpChallenge []++-- # stepEmpty+step+ :: forall i k r+ . ( HasFilter i+ , Ord k+ , Monoid r, Commutative r, Eq r+ )+ => [k]+ -> Maybe i+ -> Challenge i k r+ -> (Results k r, Challenge i k r)+step _ _ Empty = pure empty++-- # stepBoth+step kctx i (Both c1 c2)+ = both <$> step kctx i c1 <*> step kctx i c2++-- # stepEitherC+step kctx i (EitherC c1 c2) = do+ c1' <- step kctx i c1+ c2' <- step kctx i c2+ case (c1', c2') of+ (Empty, _) -> prune kctx c2'+ (_, Empty) -> prune kctx c1'+ _ -> pure $ eitherC c1' c2'++-- # stepAndThen+step kctx i (AndThen c1 c2) =+ step kctx i c1 >>= \case+ Empty -> step kctx Nothing c2+ c1' -> pure $ andThen c1' c2++-- # stepRewardThen+step kctx i (RewardThen r c) = do+ tellReward r+ step kctx i c++-- # stepGate+step kctx (Just i) (Gate f c)+ | matches f i = step kctx Nothing c+step _ _ c@Gate{} = pure c++-- # stepClue+step kctx i (Clue k c) = do+ let kctx' = kctx <> [k]+ step kctx' i c >>= \case+ Empty -> do+ tellClue $ singleton kctx' completed+ pure empty+ c' -> do+ tellClue $ singleton kctx' seen+ pure $ clue [k] c'++prune+ :: (Ord k, Monoid r)+ => [k]+ -> Challenge i k r+ -> (Results k r, Challenge i k r)+prune kctx c = do+ tellClue $ fmap (<> failed) $ findClues kctx c+ pure empty+++tellReward+ :: (Ord k, MonadWriter (Results k r) m)+ => r -> m ()+tellReward r = tell $ Results r mempty+++tellClue+ :: (Monoid r , MonadWriter (Results k r) m)+ => MonoidalMap [k] ClueState -> m ()+tellClue k = tell $ Results mempty k++------------------------------------------------------------------------------++clue+ :: forall i k r+ . ( Eq r, Monoid r, Commutative r)+ => [k] -> Challenge i k r -> Challenge i k r+clue [] c = c+clue k (RewardThen r c) = rewardThen r (clue k c)+clue k c = foldr Clue c k+++reward+ :: forall i k r+ . (Eq r, Monoid r, Commutative r)+ => r -> Challenge i k r+reward r = rewardThen r empty+++bottom :: forall i k r. Challenge i k r+bottom = gate never empty+++rewardThen+ :: forall i k r+ . (Eq r, Monoid r, Commutative r)+ => r -> Challenge i k r -> Challenge i k r+rewardThen r c | r == mempty = c+rewardThen r' (RewardThen r c) = RewardThen (r <> r') c+rewardThen r c = RewardThen r c+++gate+ :: forall i k r+ . InputFilter i+ -> Challenge i k r+ -> Challenge i k r+gate = Gate+++both+ :: forall i k r+ . (Eq r, Monoid r, Commutative r)+ => Challenge i k r+ -> Challenge i k r+ -> Challenge i k r+both (RewardThen r c1) c2 = rewardThen r (both c1 c2)+both c1 (RewardThen r c2) = rewardThen r (both c1 c2)+both Empty c2 = c2+both c1 Empty = c1+both c1 c2 = Both c1 c2+++empty :: forall i k r. Challenge i k r+empty = Empty+++andThen+ :: forall i k r+ . ( Monoid r, Commutative r, Eq r+ )+ => Challenge i k r+ -> Challenge i k r+ -> Challenge i k r+andThen Empty c = c+andThen (Gate f c1) c2 = gate f (andThen c1 c2)+andThen (RewardThen r c1) c2 =+ rewardThen r (andThen c1 c2)+andThen (AndThen c1 c2) c3 =+ andThen c1 (andThen c2 c3)+andThen c1 c2 = AndThen c1 c2+++eitherC+ :: forall i k r+ . (Eq r, Monoid r, Commutative r)+ => Challenge i k r+ -> Challenge i k r+ -> Challenge i k r+eitherC (RewardThen r c1) c2 =+ rewardThen r (eitherC c1 c2)+eitherC c1 (RewardThen r c2) =+ rewardThen r (eitherC c1 c2)+eitherC c1 c2 = EitherC c1 c2+++isValid+ :: forall i k r+ . Challenge i k r -> Bool+isValid (AndThen Empty _) = False+isValid (Both Empty _) = False+isValid (Both _ Empty) = False+isValid (EitherC _ Empty) = False+isValid (EitherC Empty _) = False+isValid (Both (RewardThen _ _) _) = False+isValid (Both _ (RewardThen _ _)) = False+isValid (EitherC (RewardThen _ _) _) = False+isValid (EitherC _ (RewardThen _ _)) = False+isValid _ = True++#include "spec.inc"+
+ src/Scavenge/InputFilter.hs view
@@ -0,0 +1,152 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++module Scavenge.InputFilter where++import Data.Word+import QuickSpec+import Test.QuickCheck+import GHC.Generics+++class HasFilter i where+ data CustomFilter i -- ! 1+ filterMatches :: CustomFilter i -> i -> Bool++------------------------------------------------------------------------------++data InputFilter i+ = Always+ | Never+ | And (InputFilter i) (InputFilter i)+ | Or (InputFilter i) (InputFilter i)+ | Not (InputFilter i)+ | Custom (CustomFilter i)+ deriving stock (Generic)++deriving stock instance (Eq (CustomFilter i)) => Eq (InputFilter i)+deriving stock instance (Ord (CustomFilter i)) => Ord (InputFilter i)+deriving stock instance (Show (CustomFilter i)) => Show (InputFilter i)++-- # ArbitraryInputFilter+instance Arbitrary (CustomFilter i) => Arbitrary (InputFilter i) where+ arbitrary = sized $ \n ->+ case n <= 1 of+ True -> elements [always, never]+ False -> frequency+ [ (3, pure always)+ , (3, pure never)+ , (5, andF <$> decayArbitrary 2+ <*> decayArbitrary 2)+ , (5, orF <$> decayArbitrary 2+ <*> decayArbitrary 2)+ , (4, notF <$> decayArbitrary 2)+ , (8, custom <$> arbitrary)+ ]++ shrink Always = []+ shrink Never = []+ shrink x = Always : Never : genericShrink x++instance (Arbitrary i, HasFilter i)+ => Observe i Bool (InputFilter i) where+ observe = flip matches++always :: InputFilter i+always = Always++never :: InputFilter i+never = Never++andF :: InputFilter i -> InputFilter i -> InputFilter i+andF = And++orF :: InputFilter i -> InputFilter i -> InputFilter i+orF = Or++notF :: InputFilter i -> InputFilter i+notF = Not++custom :: CustomFilter i -> InputFilter i+custom = Custom++------------------------------------------------------------------------------++matches :: HasFilter i => InputFilter i -> i -> Bool+matches Always _ = True+matches Never _ = False+matches (And f1 f2) i = matches f1 i && matches f2 i+matches (Or f1 f2) i = matches f1 i || matches f2 i+matches (Not f) i = not $ matches f i+matches (Custom f) i = filterMatches f i++------------------------------------------------------------------------------++decayArbitrary :: Arbitrary a => Int -> Gen a+decayArbitrary n = scale (`div` n) arbitrary++------------------------------------------------------------------------------++data Test+ = Number Word8+ deriving stock (Eq, Ord, Show, Generic)++-- # ArbitraryTest+instance Arbitrary Test where+ arbitrary = Number <$> arbitrary++ shrink = genericShrink++-- # ArbitraryInputTest+instance Arbitrary (CustomFilter Test) where+ arbitrary = Exactly <$> arbitrary++ shrink = genericShrink++exactly :: Word8 -> InputFilter Test+exactly = custom . Exactly++-- # HasFilterTest+instance HasFilter Test where+ data CustomFilter Test = Exactly Word8+ deriving stock (Eq, Ord, Show, Generic)+ filterMatches (Exactly n') (Number n) = n == n'++------------------------------------------------------------------------------++sig_filters :: Sig+sig_filters = signature+ [ sig_filter_cons+ , sig_filter_user_cons+ , sig_filter_types+ ]++sig_filter_cons :: Sig+sig_filter_cons = signature+ [ con "always" $ always @Test+ , con "never" $ never @Test+ , con "andF" $ andF @Test+ , con "orF" $ orF @Test+ , con "notF" $ notF @Test+ , con "matches" $ matches @Test+ , bools -- ! 1+ ]++sig_filter_user_cons :: Sig+sig_filter_user_cons = signature+ [ con "exactly" exactly+ , con "Number" Number+ ]++sig_filter_types :: Sig+sig_filter_types = signature+ [ monoVars @(CustomFilter Test) ["f"]+ , monoVars @(Test) ["i"]+ , monoVars @Word8 ["n"]+ , monoObserve @(InputFilter Test)+ , variableUse Linear $ Proxy @(InputFilter Test)+ ]+
+ src/Scavenge/Results.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Scavenge.Results where++import Test.QuickCheck+import GHC.Generics+import QuickSpec+import Data.Map.Monoidal (MonoidalMap, toList, fromList)+import Generic.Data+import Scavenge.ClueState++data Results k r = Results+ { rewards :: r+ , clues :: MonoidalMap [k] ClueState+ }+ deriving stock (Eq, Ord, Generic)+ deriving (Semigroup, Monoid)+ via Generically (Results k r)++instance (Show k, Show r) => Show (Results k r) where+ show (Results r k) = mconcat+ [ "Results ("+ , show r+ , ") (fromList "+ , show $ toList k+ , ")"+ ]++instance (Arbitrary k, Ord k, Arbitrary v)+ => Arbitrary (MonoidalMap k v) where+ arbitrary = fromList <$> arbitrary+ shrink = fmap fromList . genericShrink . toList++instance (Ord k, Ord v) => Observe () (MonoidalMap k v) (MonoidalMap k v)++instance (Ord k, Ord r)+ => Observe () (Results k r) (Results k r) where+
+ src/Scavenge/Sigs.hs view
@@ -0,0 +1,100 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Scavenge.Sigs where++import qualified Data.Map.Monoidal as M+import QuickSpec+import Scavenge.ClueState+import Scavenge.Initial+import Scavenge.InputFilter+import Scavenge.Test+++sig :: Sig+sig = signature+ [ sig_cons+ , sig_types+ , sig_monoid+ ]++sig_monoid :: Sig+sig_monoid = background+ [ con "mempty" $ liftC @(Monoid A) $ mempty @A+ , con "<>" $ liftC @(Semigroup A) $ (<>) @A+ ]++sig_cons :: Sig+sig_cons = signature+ [ con "both" $ both @Test @TestClue @TestReward+ , con "eitherC" $ eitherC @Test @TestClue @TestReward+ , con "empty" $ empty @Test @TestClue @TestReward+ , con "clue" $ clue @Test @TestClue @TestReward+ , con "andThen" $ andThen @Test @TestClue @TestReward+ , con "reward" $ reward @Test @TestClue @TestReward+ , con "gate" $ gate @Test @TestClue @TestReward+ , con "bottom" $ bottom @Test @TestClue @TestReward+ ]++-- TODO(sandy): write about this?+sig_obs :: Sig+sig_obs = series+ [ sig_cons+ , lists+ , signature+ [ con "stateOf" $ \c k is ->+ M.lookup [k] $ getClues @Test @TestClue @TestReward c is+ , con "prune" $ \k ->+ eitherC @Test @TestClue @TestReward empty (clue k bottom)+ , con "Just" $ Just @ClueState+ , con "Nothing" $ Nothing @ClueState+ , con "seen" seen+ , con "failed" failed+ , con "completed" completed+ ]+ , signature+ [ con "getRewards" $ getRewards @Test @TestClue @TestReward+ ]+ ]+++sig_opts :: Sig+sig_opts = signature+ [ variableUse Linear $ -- ! 1+ Proxy @(Challenge Test TestClue TestReward)+ , withMaxTermSize 6+ ]++sig_test_opts :: Sig+sig_test_opts = signature+ [ withMaxTermSize 7+ , withMaxTests 1000000+ , withMaxTestSize 40+ , withPrintStyle ForQuickCheck+ ]++sig_types :: Sig+sig_types = signature+ [ monoObserve @(Challenge Test TestClue TestReward)+ , vars ["c"] $+ Proxy @(Challenge Test TestClue TestReward)+ , monoObserve @TestReward+ , vars ["r"] $ Proxy @TestReward+ , monoObserve @(InputFilter Test)+ , vars ["f"] $ Proxy @(InputFilter Test)+ , monoVars @(CustomFilter Test) ["f"]+ , monoVars @(TestClue) ["k"]+ , monoVars @(Test) ["i"]+ , instanceOf @(Monoid [TestClue]) -- ! 1+ , instanceOf @(Semigroup [TestClue]) -- ! 1+ , instanceOf @(Monoid TestReward)+ , instanceOf @(Semigroup TestReward)+ , mono @(Maybe ClueState)+ , mono @(ClueState)+ ]+
+ src/Scavenge/Test.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Scavenge.Test where++import Data.Semigroup.Cancellative+import Data.List+import Test.QuickCheck+import QuickSpec+import Data.MultiSet (MultiSet, fromList, toList)++type TestReward = MultiSet Int++instance Commutative TestReward+instance Arbitrary TestReward where+ arbitrary = fromList <$> arbitrary+ shrink = fmap fromList . sortOn length . genericShrink . toList+instance Observe () TestReward TestReward where++type TestClue = Int+
+ src/Tiles/Efficient.hs view
@@ -0,0 +1,338 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}++module Tiles.Efficient+ ( -- * Observations+ rasterize+ , sample+ , toPNG++ -- * Generic constructors+ , empty+ , cw+ , ccw+ , beside+ , cols+ , above+ , rows+ , flipH+ , flipV+ , quad+ , swirl++ -- * Color constructors+ , behind+ , color++ -- * Special color constructors+ , haskell+ , sandy+ , spj++ -- * Color operations+ , rgba+ , invert+ , mask++ -- * Types+ , Tile+ , Color+ , pattern Color+ ) where+++import Codec.Picture.Png+import Codec.Picture.Types+import Control.Applicative hiding (empty)+import Data.FileEmbed+import Data.Functor.Compose+import qualified Data.Hashable as H+import Data.Map (Map)+import qualified Data.Map as M+import Data.Word+import QuickSpec+import Test.QuickCheck hiding (label, sample)++------------------------------------------------------------------------------++type Color = PixelRGBA8++instance Semigroup Color where+ (<>) = _over++instance Monoid Color where+ mempty = rgba 0 0 0 0++color :: Double -> Double -> Double -> Double -> Tile Color+color r g b a = pure $ rgba r g b a++rgba :: Double -> Double -> Double -> Double -> Color+rgba r g b a =+ PixelRGBA8+ (bounded r)+ (bounded g)+ (bounded b)+ (bounded a)+ where+ bounded :: Double -> Word8+ bounded x = round $ x * fromIntegral (maxBound @Word8)++pattern Color :: Double -> Double -> Double -> Double -> Color+pattern Color r g b a <-+ PixelRGBA8+ (fromIntegral -> (/255) -> r)+ (fromIntegral -> (/255) -> g)+ (fromIntegral -> (/255) -> b)+ (fromIntegral -> (/255) -> a)+ where+ Color = rgba+{-# COMPLETE Color #-}++invert :: Color -> Color+invert (Color r g b a) = Color (1 - r) (1 - g) (1 - b) a++instance Semigroup a => Semigroup (Tile a) where+ (<>) = liftA2 (<>)++instance Monoid a => Monoid (Tile a) where+ mempty = pure mempty+++newtype Tile a = Tile+ { sample :: Double -> Double -> a+ }+ deriving (Functor, Applicative)+ via (Compose ((->) Double) ((->) Double))++instance Show (Tile t) where+ show _ = "<tile>"++-- # ArbitraryTile+instance (CoArbitrary a, Arbitrary a)+ => Arbitrary (Tile a) where+ arbitrary = sized $ \n -> -- ! 1+ case n <= 1 of+ True -> pure <$> arbitrary -- ! 2+ False -> frequency -- ! 3+ [ (3,) $ pure <$> arbitrary -- ! 4+ , (9,) $ beside <$> scaledAbitrary 2 -- ! 5+ <*> scaledAbitrary 2+ , (9,) $ above <$> scaledAbitrary 2+ <*> scaledAbitrary 2+ , (2,) $ cw <$> arbitrary+ , (2,) $ ccw <$> arbitrary+ , (4,) $ flipV <$> arbitrary+ , (4,) $ flipH <$> arbitrary+ , (6,) $ swirl <$> scaledAbitrary 4+ , (3,) $ quad <$> scaledAbitrary 4+ <*> scaledAbitrary 4+ <*> scaledAbitrary 4+ <*> scaledAbitrary 4+ , (2,) $ (<*>)+ <$> scaledAbitrary @(Tile (Bool -> a)) 2+ <*> scaledAbitrary 2+ ]++scaledAbitrary :: Arbitrary a => Int -> Gen a+scaledAbitrary n = scale (`div` n) arbitrary++instance CoArbitrary PixelRGBA8 where+ coarbitrary (Color r g b a) = coarbitrary (r, g, b, a)++instance Arbitrary PixelRGBA8 where+ arbitrary = do+ a <- choose (0, 255)+ case a == 0 of+ True -> pure mempty+ False -> PixelRGBA8 <$> choose (0,255) <*> choose (0,255) <*> choose (0,255) <*> pure a++instance Monad Tile where+ Tile ma >>= f = Tile $ \x y -> sample (f (ma x y)) x y++cw :: Tile a -> Tile a+cw (Tile f) = Tile $ \x y -> f y (negate x)++ccw :: Tile a -> Tile a+ccw (Tile f) = Tile $ \x y -> f (negate y) x++_fromImage :: Image PixelRGBA8 -> Tile Color+_fromImage img@(Image w h _) = Tile $ \x y ->+ pixelAt+ img+ (coordToPixel w x)+ (coordToPixel h y)++beside :: Tile a -> Tile a -> Tile a+beside (Tile a) (Tile b) = Tile $ \x y ->+ case x >= 0 of+ False -> a (2 * (x + 0.5)) y+ True -> b (2 * (x - 0.5)) y++above :: Tile a -> Tile a -> Tile a+above (Tile a) (Tile b) = Tile $ \x y ->+ case y >= 0 of+ False -> a x (2 * (y + 0.5))+ True -> b x (2 * (y - 0.5))++behind :: Tile Color -> Tile Color -> Tile Color+behind = flip (liftA2 _over)++flipH :: Tile a -> Tile a+flipH (Tile t) = Tile $ \x y ->+ t (negate x) y++flipV :: Tile a -> Tile a+flipV (Tile t) = Tile $ \x y ->+ t x (negate y)++empty :: Tile Color+empty = pure $ PixelRGBA8 0 0 0 0++rows :: Monoid a => [Tile a] -> Tile a+rows [] = pure mempty+rows ts = Tile $ \x y ->+ let h = length ts+ i = coordToPixel h y+ in sample (ts !! i) x ((y - pixelToCoord h i) * fromIntegral h)++cols :: Monoid a => [Tile a] -> Tile a+cols [] = pure mempty+cols ts = Tile $ \x y ->+ let w = length ts+ i = coordToPixel w x+ in sample (ts !! i) ((x - pixelToCoord w i) * fromIntegral w) y++quad :: Tile a -> Tile a -> Tile a -> Tile a -> Tile a+quad a b c d = (a `beside` b) `above` (c `beside` d)++swirl :: Tile a -> Tile a+swirl t = quad t (cw t) (ccw t) $ cw $ cw t++_over :: Color -> Color -> Color+_over (PixelRGBA8 r1 g1 b1 a1) (PixelRGBA8 r2 g2 b2 a2) =+ let aa = norm a1+ ab = norm a2+ a' = aa + ab * (1 - aa)+ norm :: Word8 -> Double+ norm x = fromIntegral x / 255+ unnorm :: Double -> Word8+ unnorm x = round $ x * 255+ f :: Word8 -> Word8 -> Word8+ f a b = unnorm $ (norm a * aa + norm b * ab * (1 - aa)) / a'+ in+ PixelRGBA8 (f r1 r2) (f g1 g2) (f b1 b2) (unnorm a')++mask :: Color -> Color -> Color+mask (PixelRGBA8 _ _ _ a) (PixelRGBA8 r g b _) = PixelRGBA8 r g b a+++--------------------------------------------------------------------------------++toPNG :: Int -> Int -> Tile Color -> Image PixelRGBA8+toPNG w h t = generateImage (samplePixel w h t) w h+++samplePixel+ :: Int -- ^ width+ -> Int -- ^ height+ -> Tile a+ -> Int -- ^ x+ -> Int -- ^ y+ -> a+samplePixel w h = \t x y ->+ sample t (pixelToCoord w x) (pixelToCoord h y)++coordToPixel :: Int -> Double -> Int+coordToPixel w = \x ->+ let x' = (x + 1) * fromIntegral w / 2+ in max 0 $ min (w - 1) $ floor x'++pixelToCoord :: Int -> Int -> Double+pixelToCoord w = \x ->+ let xspan = 2 / fromIntegral w+ x' = (fromIntegral x + 0.5) * xspan+ in (-1 + x')++--------------------------------------------------------------------------------+++haskell :: Tile Color+haskell = do+ let Right (ImageRGBA8 img) = decodePng $(embedFile "static/haskell.png")+ in _fromImage img+{-# NOINLINE haskell #-}++sandy :: Tile Color+sandy =+ let Right (ImageRGBA8 img) = decodePng $(embedFile "static/sandy.png")+ in _fromImage img+{-# NOINLINE sandy #-}++spj :: Tile Color+spj = do+ let Right (ImageRGBA8 img) = decodePng $(embedFile "static/spj.png")+ in _fromImage img+{-# NOINLINE spj #-}++++--------------------------------------------------------------------------------++------------------------------------------------------------------------------+-- | Rasterize a 'Tile' down into a row-major representation of its constituent+-- "pixels".+rasterize+ :: forall a+ . Int -- ^ resulting width+ -> Int -- ^ resulting heigeht+ -> Tile a+ -> [[a]] -- ^ the resulting "pixels" in row-major order+rasterize w h t = do+ y <- [0 .. (h - 1)]+ pure $ do+ x <- [0 .. (w - 1)]+ pure $ samplePixel w h t x y++_carpet :: Int -> Int -> Tile Color+_carpet 0 _ = _black+_carpet n h =+ let carpet' dh = _carpet (n - 1) (H.hash (h, dh :: Int))+ in rows+ [ cols [ carpet' 0, carpet' 1, carpet' 2 ]+ , cols [ carpet' 3, _colors M.! (h `mod` length _colors), carpet' 4 ]+ , cols [ carpet' 5, carpet' 6, carpet' 7 ]+ ]+++_colors :: Map Int (Tile Color)+_colors = M.fromList $ zip [0..]+ [ color 1 0 0 1+ , color 1 p 0 1+ , color 1 1 0 1+ , color p 1 0 1+ , color 0 1 0 1+ , color 0 1 p 1+ , color 0 1 1 1+ , color 0 p 1 1+ , color 0 0 1 1+ , color p 0 1 1+ , color 1 0 1 1+ , color 1 0 p 1+ ]+ where+ p = 0.8++_black :: Tile Color+_black = color 0 0 0 1+
+ src/Tiles/Initial.hs view
@@ -0,0 +1,374 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}++module Tiles.Initial+ ( -- * Observations+ rasterize+ , rasterize'+ , toPNG++ -- * Generic constructors+ , empty+ , cw+ , ccw+ , beside+ , cols+ , above+ , rows+ , flipH+ , flipV+ , quad+ , swirl++ -- * Color constructors+ , behind+ , color++ -- * Special color constructors+ , haskell+ , sandy+ , spj++ -- * Color operations+ , rgba+ , invert+ , mask++ -- * QuickSpec signatures+ , sig++ -- * Types+ , Tile+ , Color+ , pattern Color+ ) where++import Codec.Picture.Png+import Codec.Picture.Types+import Control.Applicative hiding (empty)+import Data.Coerce+import Data.FileEmbed+import Data.Functor.Compose+import Data.List (transpose)+import Data.Word+import QuickSpec+import Test.QuickCheck hiding (label, sample)++------------------------------------------------------------------------------++type Color = PixelRGBA8++instance Semigroup Color where+ (<>) = _over++instance Monoid Color where+ mempty = rgba 0 0 0 0++color :: Double -> Double -> Double -> Double -> Tile Color+color r g b a = pure $ rgba r g b a++rgba :: Double -> Double -> Double -> Double -> Color+rgba r g b a =+ PixelRGBA8+ (bounded r)+ (bounded g)+ (bounded b)+ (bounded a)+ where+ bounded :: Double -> Word8+ bounded x = round $ x * fromIntegral (maxBound @Word8)++pattern Color :: Double -> Double -> Double -> Double -> Color+pattern Color r g b a <-+ PixelRGBA8+ (fromIntegral -> (/255) -> r)+ (fromIntegral -> (/255) -> g)+ (fromIntegral -> (/255) -> b)+ (fromIntegral -> (/255) -> a)+ where+ Color = rgba+{-# COMPLETE Color #-}++invert :: Color -> Color+invert (Color r g b a) = Color (1 - r) (1 - g) (1 - b) a++-- # SemigroupTile+instance Semigroup a => Semigroup (Tile a) where+ (<>) = liftA2 (<>)++-- # MonoidTile+instance Monoid a => Monoid (Tile a) where+ mempty = pure mempty+++data Tile a+ = Cw (Tile a)+ | FlipH (Tile a)+ | Above [Tile a]+ | Pure a+ | forall b. Ap (Tile (b -> a)) (Tile b)++instance Functor Tile where+ fmap f = (pure f <*>)++instance Applicative Tile where+ pure = Pure+ (<*>) = Ap++instance Show a => Show (Tile a) where+ show (Cw t) = "cw (" ++ show t ++ ")"+ show (FlipH t) = "flipH (" ++ show t ++ ")"+ show (Above [a,b]) = "above (" ++ show a ++ ") (" ++ show b ++ ")"+ show (Above as) = "rows " ++ show as+ show (Pure a) = "pure (" ++ show a ++ ")"+ show (Ap _ _) = "ap _ _"++-- # ArbitraryTile+instance (CoArbitrary a, Arbitrary a)+ => Arbitrary (Tile a) where+ arbitrary = sized $ \n -> -- ! 1+ case n <= 1 of+ True -> pure <$> arbitrary -- ! 2+ False -> frequency -- ! 3+ [ (3,) $ pure <$> arbitrary -- ! 4+ , (9,) $ beside <$> decayArbitrary 2 -- ! 5+ <*> decayArbitrary 2+ , (9,) $ above <$> decayArbitrary 2+ <*> decayArbitrary 2+ , (2,) $ cw <$> arbitrary+ , (2,) $ ccw <$> arbitrary+ , (4,) $ flipV <$> arbitrary+ , (4,) $ flipH <$> arbitrary+ , (6,) $ swirl <$> decayArbitrary 4+ , (3,) $ quad <$> decayArbitrary 4+ <*> decayArbitrary 4+ <*> decayArbitrary 4+ <*> decayArbitrary 4+ , (2,) $ (<*>)+ <$> decayArbitrary @(Tile (a -> a)) 2+ <*> decayArbitrary 2+ ]++ shrink (Cw t) = t : (cw <$> shrink t)+ shrink (FlipH t) = t : (flipH <$> shrink t)+ shrink (Above ts) = ts ++ filter valid (fmap Above (shrink ts))+ shrink (Pure a) = pure <$> shrink a+ shrink (Ap _ _) = []++valid :: Tile a -> Bool+valid (Above []) = False+valid _ = True++instance Observe () Color Color++-- # ObserveTile+instance Observe test outcome [[a]]+ => Observe+ (Small Int, Small Int, test)+ outcome+ (Tile a) where+ observe (Small w, Small h, x) t+ = observe x (rasterize (max 1 w) (max 1 h) t)++decayArbitrary :: Arbitrary a => Int -> Gen a+decayArbitrary n = scale (`div` n) arbitrary++instance CoArbitrary PixelRGBA8 where+ coarbitrary (Color r g b a) = coarbitrary (r, g, b, a)++instance Arbitrary PixelRGBA8 where+ arbitrary = do+ a <- choose (0, 255)+ case a == 0 of+ True -> pure mempty+ False -> PixelRGBA8 <$> choose (0,255) <*> choose (0,255) <*> choose (0,255) <*> pure a++cw :: Tile a -> Tile a+cw (Cw (Cw (Cw x))) = x+cw x = Cw x++ccw :: Tile a -> Tile a+ccw (Cw x) = x+ccw x = cw (cw (cw x))++_fromImage :: Image PixelRGBA8 -> Tile Color+_fromImage img@(Image w h _) = rows $ do+ y <- [0 .. h - 1]+ pure $ cols $ do+ x <- [0 .. w - 1]+ pure $ pure $ pixelAt img x y++beside :: Tile a -> Tile a -> Tile a+beside t1 t2 = ccw (above (cw t1) (cw t2))++above :: Tile a -> Tile a -> Tile a+above t1 t2 = Above [t1, t2]++behind :: Monoid a => Tile a -> Tile a -> Tile a+behind = flip (liftA2 (<>))++flipH :: Tile a -> Tile a+flipH (FlipH t) = t+flipH t = FlipH t++flipV :: Tile a -> Tile a+flipV = ccw . flipH . cw++empty :: Monoid a => Tile a+empty = pure mempty++rows :: Monoid a => [Tile a] -> Tile a+rows [] = pure mempty+rows [x] = x+rows ts = Above ts++cols :: Monoid a => [Tile a] -> Tile a+cols [] = pure mempty+cols [x] = x+cols ts = ccw . rows $ fmap cw ts+++quad :: Tile a -> Tile a -> Tile a -> Tile a -> Tile a+quad t1 t2 t3 t4 = (t1 `beside` t2) `above` (t3 `beside` t4)++swirl :: Tile a -> Tile a+swirl t = quad t (cw t) (ccw t) $ cw $ cw t++_over :: Color -> Color -> Color+_over (PixelRGBA8 r1 g1 b1 a1) (PixelRGBA8 r2 g2 b2 a2) =+ let aa = norm a1+ ab = norm a2+ a' = aa + ab * (1 - aa)+ norm :: Word8 -> Double+ norm x = fromIntegral x / 255+ unnorm :: Double -> Word8+ unnorm x = round $ x * 255+ f :: Word8 -> Word8 -> Word8+ f a b = unnorm $ (norm a * aa + norm b * ab * (1 - aa)) / a'+ in+ PixelRGBA8 (f r1 r2) (f g1 g2) (f b1 b2) (unnorm a')++mask :: Color -> Color -> Color+mask (PixelRGBA8 _ _ _ a) (PixelRGBA8 r g b _) = PixelRGBA8 r g b a+++----------------------------------------------------------------------------------++toPNG :: Int -> Int -> Tile Color -> Image PixelRGBA8+toPNG w h t = generateImage f w h+ where+ img = rasterize w h t+ f x y = img !! y !! x++----------------------------------------------------------------------------------+++haskell :: Tile Color+haskell = do+ let Right (ImageRGBA8 img) = decodePng $(embedFile "static/haskell.png")+ in _fromImage img+{-# NOINLINE haskell #-}++sandy :: Tile Color+sandy =+ let Right (ImageRGBA8 img) = decodePng $(embedFile "static/sandy.png")+ in _fromImage img+{-# NOINLINE sandy #-}++spj :: Tile Color+spj = do+ let Right (ImageRGBA8 img) = decodePng $(embedFile "static/spj.png")+ in _fromImage img+{-# NOINLINE spj #-}++++------------------------------------------------------------------------------+-- | Rasterize a 'Tile' down into a row-major representation of its constituent+-- "pixels".+rasterize :: Int -> Int -> Tile a -> [[a]]+rasterize w h (Pure a) = replicate h $ replicate w a+rasterize w h (Ap f a) =+ coerce (rasterize' w h f <*> rasterize' w h a)+rasterize w h (FlipH t) = fmap reverse $ rasterize w h t+rasterize w h (Cw t) = rotate2d $ rasterize h w t+ where+ rotate2d = fmap reverse . transpose+rasterize w h (Above [t]) = rasterize w h t+rasterize _ _ (Above []) = error "you broke the invariant!"+rasterize w h (Above z@(t:ts))+ | h >= length z =+ let h' = div h (length z)+ in rasterize w h' t <>+ rasterize w (h - h') (Above ts)+ | otherwise =+ let zspan = fromIntegral @_ @Double (length z) / fromIntegral h+ in rasterize w h $ Above $ do+ y <- [0..h-1]+ pure $ ts !! floor (fromIntegral y * zspan)+++------------------------------------------------------------------------------+-- | Like 'rasterize'', but with a type more convenient for showing off the+-- applicative homomorphism.+rasterize'+ :: Int -- ^ resulting width+ -> Int -- ^ resulting heigeht+ -> Tile a+ -> Compose ZipList ZipList a -- ^ the resulting "pixels" in row-major order+rasterize' w h t = coerce $ rasterize w h t++sig :: Sig+sig = sig_bg <> sig_cons <> sig_types+++sig_bg :: Sig+sig_bg = background+ [ con "<>" $ liftC @(Monoid A) $ (<>) @A+ , con "mempty" $ liftC @(Monoid A) $ mempty @A+ ]++sig_cons :: Sig+sig_cons = signature+ [ con "cw" $ cw @A -- ! 1+ , con "ccw" $ ccw @A+ , con "beside" $ beside @A+ , con "above" $ above @A+ , con "flipV" $ flipV @A+ , con "flipH" $ flipH @A+ , con "pure" $ pure @Tile @A+ , con "<*>" $ (<*>) @Tile @A @B+ , con "quad" $ quad @A+ , con "swirl" $ swirl @A+ , con "behind" $ liftC @(Monoid A) $ behind @A -- ! 2+ , con "empty" $ liftC @(Monoid A) $ empty @A+ ]+++sig_types :: forall m. (m ~ [Word8]) => Sig+sig_types = signature+ [ mono @m -- ! 1+ , monoObserve @(Tile m) -- ! 2+ , monoObserve @(Tile (m -> m))+ , instanceOf @(Monoid m) -- ! 3+ , instanceOf @(Monoid (Tile m))+ , vars ["t"] $ Proxy @(Tile A) -- ! 4+ , vars ["tf"] $ Proxy @(Tile (A -> B))+ , defaultTo $ Proxy @m -- ! 5+ , withMaxTermSize 5+ ]++
static/haskell.png view
binary file changed (9850 → 37529 bytes)
static/sandy.png view
binary file changed (104831 → 251825 bytes)
+ static/spj.png view
binary file changed (absent → 70440 bytes)