diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,1 +1,3 @@ # algebra-driven-design + +[![Hackage](https://img.shields.io/hackage/v/algebra-driven-design.svg?logo=haskell&label=algebra-driven-design)](https://hackage.haskell.org/package/algebra-driven-design) diff --git a/algebra-driven-design.cabal b/algebra-driven-design.cabal --- a/algebra-driven-design.cabal +++ b/algebra-driven-design.cabal @@ -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 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 diff --git a/src/ADD/Games/Basic.hs b/src/ADD/Games/Basic.hs deleted file mode 100644 --- a/src/ADD/Games/Basic.hs +++ /dev/null @@ -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 - ] - diff --git a/src/ADD/Games/Correct.hs b/src/ADD/Games/Correct.hs deleted file mode 100644 --- a/src/ADD/Games/Correct.hs +++ /dev/null @@ -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) - ] - diff --git a/src/ADD/Tiles/Basic.hs b/src/ADD/Tiles/Basic.hs deleted file mode 100644 --- a/src/ADD/Tiles/Basic.hs +++ /dev/null @@ -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 _ = "" - -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 - diff --git a/src/ADD/Tiles/Functor.hs b/src/ADD/Tiles/Functor.hs deleted file mode 100644 --- a/src/ADD/Tiles/Functor.hs +++ /dev/null @@ -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 _ = "" - -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 - diff --git a/src/Scavenge/CPS.hs b/src/Scavenge/CPS.hs new file mode 100644 --- /dev/null +++ b/src/Scavenge/CPS.hs @@ -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 #-} + diff --git a/src/Scavenge/ClueState.hs b/src/Scavenge/ClueState.hs new file mode 100644 --- /dev/null +++ b/src/Scavenge/ClueState.hs @@ -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 + ] + diff --git a/src/Scavenge/Initial.hs b/src/Scavenge/Initial.hs new file mode 100644 --- /dev/null +++ b/src/Scavenge/Initial.hs @@ -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" + diff --git a/src/Scavenge/InputFilter.hs b/src/Scavenge/InputFilter.hs new file mode 100644 --- /dev/null +++ b/src/Scavenge/InputFilter.hs @@ -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) + ] + diff --git a/src/Scavenge/Results.hs b/src/Scavenge/Results.hs new file mode 100644 --- /dev/null +++ b/src/Scavenge/Results.hs @@ -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 + diff --git a/src/Scavenge/Sigs.hs b/src/Scavenge/Sigs.hs new file mode 100644 --- /dev/null +++ b/src/Scavenge/Sigs.hs @@ -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) + ] + diff --git a/src/Scavenge/Test.hs b/src/Scavenge/Test.hs new file mode 100644 --- /dev/null +++ b/src/Scavenge/Test.hs @@ -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 + diff --git a/src/Tiles/Efficient.hs b/src/Tiles/Efficient.hs new file mode 100644 --- /dev/null +++ b/src/Tiles/Efficient.hs @@ -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 _ = "" + +-- # 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 + diff --git a/src/Tiles/Initial.hs b/src/Tiles/Initial.hs new file mode 100644 --- /dev/null +++ b/src/Tiles/Initial.hs @@ -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 + ] + + diff --git a/static/haskell.png b/static/haskell.png Binary files a/static/haskell.png and b/static/haskell.png differ diff --git a/static/sandy.png b/static/sandy.png Binary files a/static/sandy.png and b/static/sandy.png differ diff --git a/static/spj.png b/static/spj.png new file mode 100644 Binary files /dev/null and b/static/spj.png differ