algebra-driven-design (empty) → 0.1.0.0
raw patch · 9 files changed
+1812/−0 lines, 9 filesdep +JuicyPixelsdep +QuickCheckdep +basesetup-changed
Dependencies added: JuicyPixels, QuickCheck, base, containers, file-embed, mtl, quickspec
Files
- ChangeLog.md +3/−0
- LICENSE +30/−0
- README.md +1/−0
- Setup.hs +2/−0
- algebra-driven-design.cabal +48/−0
- src/ADD/Games/Basic.hs +313/−0
- src/ADD/Games/Correct.hs +676/−0
- src/ADD/Tiles/Basic.hs +360/−0
- src/ADD/Tiles/Functor.hs +379/−0
+ ChangeLog.md view
@@ -0,0 +1,3 @@+# Changelog for algebra-driven-design++## Unreleased changes
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Sandy Maguire (c) 2020++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Sandy Maguire nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,1 @@+# algebra-driven-design
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ algebra-driven-design.cabal view
@@ -0,0 +1,48 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.31.2.+--+-- see: https://github.com/sol/hpack+--+-- hash: 3ed128c427dd13497c2ce7ee7d002afe69df0d4577e9d66c0ccb4636382bfe31++name: algebra-driven-design+version: 0.1.0.0+synopsis: Companion library for the book Algebra-Driven Design by Sandy Maguire+description: Please see the README on GitHub at <https://github.com/isovector/algebra-driven-design#readme>+category: Book+homepage: https://github.com/isovector/algebra-driven-design#readme+bug-reports: https://github.com/isovector/algebra-driven-design/issues+author: Sandy Maguire+maintainer: sandy@sandymaguire.me+copyright: 2020 Sandy Maguire+license: BSD3+license-file: LICENSE+build-type: Simple+extra-source-files:+ README.md+ ChangeLog.md++source-repository head+ type: git+ location: https://github.com/isovector/algebra-driven-design++library+ exposed-modules:+ ADD.Games.Basic+ ADD.Games.Correct+ ADD.Tiles.Basic+ ADD.Tiles.Functor+ other-modules:+ Paths_algebra_driven_design+ hs-source-dirs:+ src+ build-depends:+ JuicyPixels+ , QuickCheck+ , base >=4.7 && <5+ , containers+ , file-embed+ , mtl+ , quickspec+ default-language: Haskell2010
+ src/ADD/Games/Basic.hs view
@@ -0,0 +1,313 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeApplications #-}++module ADD.Games.Basic where++import Data.Data+import Data.Word+import GHC.Generics+import Test.QuickCheck hiding (Result, choose)+import Control.Monad.Writer+import Data.Tuple (swap)+import Data.List+import QuickSpec++data Event = Event Word8+ deriving stock (Eq, Ord, Show, Data, Generic)++-- # ArbitraryEvent+instance Arbitrary Event where+ arbitrary = Event <$> arbitrary+ shrink = genericShrink+++data EventFilter+ = Always+ | Never+ | Exactly Word8 -- ! 1+ deriving stock (Eq, Ord, Show, Data, Generic)++-- # ArbitraryEventFilter+instance Arbitrary EventFilter where+ arbitrary = frequency+ [ (3, pure Always)+ , (1, pure Never)+ , (5, Exactly <$> arbitrary)+ ]+ shrink = genericShrink++always :: EventFilter+always = Always++never :: EventFilter+never = Never++sig_filters :: Sig+sig_filters = signature+ [ con "always" always+ , con "never" never+ ]+++data Reward = Reward Word8+ deriving stock (Eq, Ord, Show, Data, Generic)++-- # ArbitraryReward+instance Arbitrary Reward where+ arbitrary = Reward <$> arbitrary+ shrink = genericShrink+++data Result+ = Victory+ | Defeat+ deriving stock (Eq, Ord, Show, Data, Generic)++-- # ArbitraryResult+instance Arbitrary Result where+ arbitrary = elements [ victory, defeat ]+ shrink = genericShrink++victory :: Result+victory = Victory++defeat :: Result+defeat = Defeat++sig_results :: Sig+sig_results = signature+ [ con "victory" victory+ , con "defeat" defeat+ ]+++------------------------------------------------------------------------------+-- constructors+------------------------------------------------------------------------------++data Game+ = Win+ | Lose+ | GiveReward Reward+ | AndThen Game Game+ | Subgame Game Game Game+ | EitherG Game Game+ | Both Game Game+ | Race Game Game+ | Choose [(EventFilter, Game)]+ deriving stock (Eq, Ord, Show, Data, Generic)++-- # ArbitraryGame+instance Arbitrary Game where+ arbitrary = sized $ \n ->+ case n <= 1 of+ True -> elements [win, lose]+ False -> frequency+ [ (3, pure win)+ , (3, pure lose)+ , (3, reward <$> arbitrary)+ , (5, andThen <$> decayArbitrary 2+ <*> decayArbitrary 2)+ , (5, subgame <$> decayArbitrary 3+ <*> decayArbitrary 3+ <*> decayArbitrary 3)+ , (5, both <$> decayArbitrary 2+ <*> decayArbitrary 2)+ , (5, eitherG <$> decayArbitrary 2+ <*> decayArbitrary 2)+ , (5, race <$> decayArbitrary 2+ <*> decayArbitrary 2)+ , (5, choose <$> decayArbitrary 5)+ , (2, comeback <$> arbitrary)+ , (1, pure bottom)+ , (5, gate <$> arbitrary <*> arbitrary)+ ]+ shrink = genericShrink++-- # ObserveGame+instance+ Observe [Event] ([Reward], Maybe Result) Game+ where+ observe = runGame++decayArbitrary :: Arbitrary a => Int -> Gen a+decayArbitrary n = scale (`div` n) arbitrary++reward :: Reward -> Game+reward = GiveReward++win :: Game+win = Win++lose :: Game+lose = Lose++andThen :: Game -> Game -> Game+andThen Win _ = win+andThen Lose _ = lose+andThen a b = AndThen a b++subgame :: Game -> Game -> Game -> Game+subgame Win g1 _ = g1+subgame Lose _ g2 = g2+subgame g g1 g2 = Subgame g g1 g2++eitherG :: Game -> Game -> Game+eitherG Lose Lose = lose+eitherG Win _ = win+eitherG _ Win = win+eitherG a b = EitherG a b++both :: Game -> Game -> Game+both Win Win = win+both Lose _ = lose+both _ Lose = lose+both a b = Both a b++race :: Game -> Game -> Game+race Win _ = win+race Lose _ = lose+race _ Win = win+race _ Lose = lose+race a b = Race a b++choose :: [(EventFilter, Game)] -> Game+choose cs = Choose cs++sig_games_core :: Sig+sig_games_core = signature+ [ con "win" win+ , con "lose" lose+ , con "reward" reward+ , con "andThen" andThen+ , con "subgame" subgame+ , con "eitherG" eitherG+ , con "both" both+ , con "race" race+ , con "choose" choose+ ]++------------------------------------------------------------------------------+-- extensions+------------------------------------------------------------------------------++comeback :: Game -> Game+comeback g = subgame g lose win++bottom :: Game+bottom = choose []++gate :: EventFilter -> Game -> Game+gate ef g = choose [(ef, g)]++sig_games_ext :: Sig+sig_games_ext = signature+ [ con "comeback" comeback+ , con "bottom" bottom+ , con "gate" gate+ ]+++bingo :: [[Game]] -> Reward -> Game+bingo squares r+ = let subgames = squares+ ++ transpose squares -- ! 1+ allOf :: [Game] -> Game+ allOf = foldr both win+ anyOf :: [Game] -> Game+ anyOf = foldr eitherG lose+ in anyOf (fmap allOf subgames) `andThen` reward r++------------------------------------------------------------------------------+-- tests+------------------------------------------------------------------------------++bingo_game :: Game+bingo_game = flip bingo (Reward 100) $ do+ x <- [0..2]+ pure $ do+ y <- [0..2]+ pure $ gate (Exactly $ x * 10 + y) win+++------------------------------------------------------------------------------+-- observations+------------------------------------------------------------------------------++runGame :: [Event] -> Game -> ([Reward], Maybe Result)+runGame evs g =+ swap $ runWriter $ fmap _toResult $ _runGame g evs++_toResult :: Game -> Maybe Result+_toResult Win = Just Victory+_toResult Lose = Just Defeat+_toResult _ = Nothing++_runGame :: Game -> [Event] -> Writer [Reward] Game+_runGame g (e : es) = do+ g' <- _stepGame g (Just e)+ _runGame g' es+_runGame g [] = do+ g' <- _stepGame g Nothing+ case g == g' of -- ! 1+ True -> pure g'+ False -> _runGame g' []++_stepGame :: Game -> Maybe Event -> Writer [Reward] Game+_stepGame Win _ = pure win+_stepGame Lose _ = pure lose+_stepGame (GiveReward r) _ = tell [r] >> pure win+_stepGame (AndThen g1 g2) e =+ andThen <$> _stepGame g1 e+ <*> pure g2+_stepGame (Subgame g g1 g2) e = -- ! 1+ subgame <$> _stepGame g e -- ! 2+ <*> pure g1+ <*> pure g2+_stepGame (EitherG g1 g2) e =+ eitherG <$> _stepGame g1 e+ <*> _stepGame g2 e+_stepGame (Both g1 g2) e =+ both <$> _stepGame g1 e+ <*> _stepGame g2 e+_stepGame (Race g1 g2) e =+ race <$> _stepGame g1 e+ <*> _stepGame g2 e+_stepGame (Choose cs) (Just e)+ | Just (_, g) <- find (\(ef, _) -> matches ef e) cs+ = pure g+_stepGame x@Choose{} _ = pure x+++matches :: EventFilter -> Event -> Bool+matches Never _ = False+matches Always _ = True+matches (Exactly e) (Event ev) = e == ev++------------------------------------------------------------------------------+-- specifications+------------------------------------------------------------------------------++sig_types :: Sig+sig_types = signature+ [ monoType $ Proxy @Event+ , monoType $ Proxy @EventFilter+ , monoType $ Proxy @Reward+ , monoType $ Proxy @Result+ , monoTypeObserve $ Proxy @Game+ , vars ["e"] $ Proxy @Event+ , vars ["ef"] $ Proxy @EventFilter+ , vars ["r"] $ Proxy @Reward+ , vars ["res"] $ Proxy @Result+ , vars ["g"] $ Proxy @Game+ ]++sig_options :: Sig+sig_options = signature+ [ withMaxTermSize 5+ ]+
+ src/ADD/Games/Correct.hs view
@@ -0,0 +1,676 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++module ADD.Games.Correct where++import Data.Foldable+import qualified Data.Set as S+import Data.Set (Set)+import Data.Data+import Data.Word+import GHC.Generics+import Test.QuickCheck hiding (Result)+import Control.Monad.Writer+import Data.Tuple (swap)+import Data.List+import QuickSpec++data Event = Event Word8+ deriving stock (Eq, Ord, Show, Data, Generic)++-- # ArbitraryEvent+instance Arbitrary Event where+ arbitrary = Event <$> arbitrary+ shrink = genericShrink+++data EventFilter+ = Always+ | Never+ | Exactly Word8 -- ! 1+ deriving stock (Eq, Ord, Show, Data, Generic)++-- # ArbitraryEventFilter+instance Arbitrary EventFilter where+ arbitrary = frequency+ [ (3, pure Always)+ , (1, pure Never)+ , (5, Exactly <$> arbitrary)+ ]+ shrink = genericShrink++always :: EventFilter+always = Always++never :: EventFilter+never = Never++sig_filters :: Sig+sig_filters = signature+ [ con "always" always+ , con "never" never+ ]+++data Reward = Reward Word8+ deriving stock (Eq, Ord, Show, Data, Generic)++-- # ArbitraryReward+instance Arbitrary Reward where+ arbitrary = Reward <$> arbitrary+ shrink = genericShrink+++data Result+ = Victory+ | Defeat+ deriving stock (Eq, Ord, Show, Data, Generic)++-- # ArbitraryResult+instance Arbitrary Result where+ arbitrary = elements [ victory, defeat ]+ shrink = genericShrink++victory :: Result+victory = Victory++defeat :: Result+defeat = Defeat++sig_results :: Sig+sig_results = signature+ [ con "victory" victory+ , con "defeat" defeat+ ]+++------------------------------------------------------------------------------+-- constructors+------------------------------------------------------------------------------++data Game+ = Win+ | Lose+ | RewardThen Reward Game+ | Subgame Game Game Game+ | EitherW Game Game+ | Both Game Game+ | Race Game Game+ | Multigate [(EventFilter, Game)]+ deriving stock (Eq, Ord, Show, Data, Generic)++-- # ArbitraryGame+instance Arbitrary Game where+ arbitrary = sized $ \n ->+ case n <= 1 of+ True -> elements [win, lose]+ False -> frequency+ [ (3, pure win)+ , (3, pure lose)+ , (3, reward <$> arbitrary)+ , (5, rewardThen <$> arbitrary+ <*> decayArbitrary 2)+ , (5, andThen <$> decayArbitrary 2+ <*> decayArbitrary 2)+ , (5, subgame <$> decayArbitrary 3+ <*> decayArbitrary 3+ <*> decayArbitrary 3)+ , (5, both <$> decayArbitrary 2+ <*> decayArbitrary 2)+ , (5, eitherG <$> decayArbitrary 2+ <*> decayArbitrary 2)+ , (5, race <$> decayArbitrary 2+ <*> decayArbitrary 2)+ , (5, multigate <$> decayArbitrary 5)+ , (2, comeback <$> arbitrary)+ , (1, pure bottom)+ , (5, gate <$> arbitrary <*> arbitrary)+ ]+ shrink = genericShrink++-- # ObserveGame+instance+ Observe [Event] (Set Reward, Maybe Result) Game+ where+ observe = runGame++decayArbitrary :: Arbitrary a => Int -> Gen a+decayArbitrary n = scale (`div` n) arbitrary++reward :: Reward -> Game+reward r = rewardThen r win++rewardThen :: Reward -> Game -> Game+rewardThen = RewardThen++win :: Game+win = Win++lose :: Game+lose = Lose++andThen :: Game -> Game -> Game+andThen g1 g2 = subgame g1 g2 lose++subgame :: Game -> Game -> Game -> Game+subgame (RewardThen r g) g1 g2 =+ rewardThen r (subgame g g1 g2)+subgame Win g1 _ = g1+subgame Lose _ g2 = g2+subgame g g1 g2 = Subgame g g1 g2++eitherG :: Game -> Game -> Game+eitherG (RewardThen r g1) g2 =+ rewardThen r (eitherG g1 g2)+eitherG g1 (RewardThen r g2) =+ rewardThen r (eitherG g1 g2)+eitherG Lose Lose = lose+eitherG Win _ = win+eitherG _ Win = win+eitherG a b = EitherW a b++both :: Game -> Game -> Game+both (RewardThen r g1) g2 = rewardThen r (both g1 g2)+both g1 (RewardThen r g2) = rewardThen r (both g1 g2)+both Win Win = win+both Lose _ = lose+both _ Lose = lose+both a b = Both a b++race :: Game -> Game -> Game+race (RewardThen r g1) g2 = rewardThen r (race g1 g2)+race g1 (RewardThen r g2) = rewardThen r (race g1 g2)+race Win _ = win+race Lose _ = lose+race _ Win = win+race _ Lose = lose+race a b = Race a b++multigate :: [(EventFilter, Game)] -> Game+multigate cs = Multigate cs++sig_games_core :: Sig+sig_games_core = signature+ [ con "win" win+ , con "lose" lose+ , con "subgame" subgame+ , con "eitherG" eitherG+ , con "both" both+ , con "race" race+ , con "multigate" multigate+ , con "rewardThen" rewardThen+ , con "gate" gate+ ]++------------------------------------------------------------------------------+-- extensions+------------------------------------------------------------------------------++comeback :: Game -> Game+comeback g = subgame g lose win++bottom :: Game+bottom = multigate []++gate :: EventFilter -> Game -> Game+gate ef g = multigate [(ef, g)]++sig_games_ext :: Sig+sig_games_ext = signature+ [ con "comeback" comeback+ , con "bottom" bottom+ , con "andThen" andThen+ , con "reward" reward+ ]+++bingo :: [[Game]] -> Reward -> Game+bingo squares r+ = let subgames = squares+ ++ transpose squares -- ! 1+ allOf :: [Game] -> Game+ allOf = foldr both win+ anyOf :: [Game] -> Game+ anyOf = foldr eitherG lose+ in subgame (anyOf (fmap allOf subgames)) (reward r) lose++------------------------------------------------------------------------------+-- tests+------------------------------------------------------------------------------++bingo_game :: Game+bingo_game = flip bingo (Reward 100) $ do+ x <- [0..2]+ pure $ do+ y <- [0..2]+ pure $ gate (Exactly $ x * 10 + y) win+++foo :: Property+foo = property $ \g g2 -> race g g2 =~= race g2 g++------------------------------------------------------------------------------+-- observations+------------------------------------------------------------------------------++runGame :: [Event] -> Game -> (Set Reward, Maybe Result)+runGame evs g =+ swap $ runWriter $ fmap _toResult $ _runGame g evs++_toResult :: Game -> Maybe Result+_toResult Win = Just Victory+_toResult Lose = Just Defeat+_toResult _ = Nothing++_runGame :: Game -> [Event] -> Writer (Set Reward) Game+_runGame g (e : es) = do+ g' <- _stepGame g (Just e)+ _runGame g' es+_runGame g [] = do+ g' <- _stepGame g Nothing+ case g == g' of -- ! 1+ True -> pure g'+ False -> _runGame g' []++_stepGame :: Game -> Maybe Event -> Writer (Set Reward) Game+_stepGame Win _ = pure win+_stepGame Lose _ = pure lose++-- # _stepGameRewardThen+_stepGame (RewardThen r g) e =+ tell (S.singleton r) >> _stepGame g e++_stepGame (Subgame g g1 g2) e = -- ! 1+ subgame <$> _stepGame g e -- ! 2+ <*> pure g1+ <*> pure g2+_stepGame (EitherW g1 g2) e =+ eitherG <$> _stepGame g1 e+ <*> _stepGame g2 e+_stepGame (Both g1 g2) e =+ both <$> _stepGame g1 e+ <*> _stepGame g2 e+_stepGame (Race g1 g2) e =+ race <$> _stepGame g1 e+ <*> _stepGame g2 e+_stepGame (Multigate cs) (Just e)+ | Just (_, g) <- find (\(ef, _) -> matches ef e) cs+ = pure g+_stepGame x@Multigate{} _ = pure x+++matches :: EventFilter -> Event -> Bool+matches Never _ = False+matches Always _ = True+matches (Exactly e) (Event ev) = e == ev++------------------------------------------------------------------------------+-- specifications+------------------------------------------------------------------------------++sig_types :: Sig+sig_types = signature+ [ monoType $ Proxy @Event+ , monoType $ Proxy @EventFilter+ , monoType $ Proxy @Reward+ , monoType $ Proxy @Result+ , monoTypeObserve $ Proxy @Game+ , vars ["e"] $ Proxy @Event+ , vars ["ef"] $ Proxy @EventFilter+ , vars ["r"] $ Proxy @Reward+ , vars ["res"] $ Proxy @Result+ , vars ["g"] $ Proxy @Game+ ]++sig_options :: Sig+sig_options = signature+ [ withMaxTermSize 5+ ]+++++quickspec_laws' :: [(String, Property)]+quickspec_laws' =+ [ ( "comeback bottom = bottom"+ , property $ comeback bottom =~= bottom)+ , ( "win = comeback lose"+ , property $ win =~= comeback lose)+ , ( "lose = comeback win"+ , property $ lose =~= comeback win)+ , ( "both g g2 = both g2 g"+ , property $+ \ (g :: Game) (g2 :: Game) ->+ both g g2 =~= both g2 g)+ , ( "both g g = g"+ , property $ \ (g :: Game) -> both g g =~= g)+ , ( "eitherG g g2 = eitherG g2 g"+ , property $+ \ (g :: Game) (g2 :: Game) ->+ eitherG g g2 =~= eitherG g2 g)+ , ( "eitherG g g = g"+ , property $ \ (g :: Game) -> eitherG g g =~= g)+ , ( "race g g = g"+ , property $ \ (g :: Game) -> race g g =~= g)+ , ( "andThen g win = g"+ , property $ \ (g :: Game) -> andThen g win =~= g)+ , ( "andThen bottom g = bottom"+ , property $+ \ (g :: Game) -> andThen bottom g =~= bottom)+ , ( "andThen lose g = lose"+ , property $+ \ (g :: Game) -> andThen lose g =~= lose)+ , ( "andThen win g = g"+ , property $ \ (g :: Game) -> andThen win g =~= g)+ , ( "both g bottom = andThen g bottom"+ , property $+ \ (g :: Game) -> both g bottom =~= andThen g bottom)+ , ( "both g win = g"+ , property $ \ (g :: Game) -> both g win =~= g)+ , ( "eitherG g lose = g"+ , property $ \ (g :: Game) -> eitherG g lose =~= g)+ , ( "race g bottom = g"+ , property $ \ (g :: Game) -> race g bottom =~= g)+ , ( "race bottom g = g"+ , property $ \ (g :: Game) -> race bottom g =~= g)+ , ( "race lose g = both g lose"+ , property $+ \ (g :: Game) -> race lose g =~= both g lose)+ , ( "race win g = eitherG g win"+ , property $+ \ (g :: Game) -> race win g =~= eitherG g win)+ , ( "gate ef bottom = bottom"+ , property $+ \ (ef :: EventFilter) -> gate ef bottom =~= bottom)+ , ( "reward r = rewardThen r win"+ , property $+ \ (r :: Reward) -> reward r =~= rewardThen r win)+ , ( "comeback (comeback g) = g"+ , property $+ \ (g :: Game) -> comeback (comeback g) =~= g)+ , ( "comeback (reward r) = rewardThen r lose"+ , property $+ \ (r :: Reward) ->+ comeback (reward r) =~= rewardThen r lose)+ , ( "andThen g g2 = subgame g g2 lose"+ , property $+ \ (g :: Game) (g2 :: Game) ->+ andThen g g2 =~= subgame g g2 lose)+ , ( "subgame bottom g g2 = bottom"+ , property $+ \ (g :: Game) (g2 :: Game) ->+ subgame bottom g g2 =~= bottom)+ , ( "subgame lose g g2 = g2"+ , property $+ \ (g :: Game) (g2 :: Game) ->+ subgame lose g g2 =~= g2)+ , ( "subgame win g g2 = g"+ , property $+ \ (g :: Game) (g2 :: Game) ->+ subgame win g g2 =~= g)+ , ( "comeback g = subgame g lose win"+ , property $+ \ (g :: Game) -> comeback g =~= subgame g lose win)+ , ( "subgame g win bottom = eitherG g bottom"+ , property $+ \ (g :: Game) ->+ subgame g win bottom =~= eitherG g bottom)+ , ( "andThen (comeback g) g2 = subgame g lose g2"+ , property $+ \ (g :: Game) (g2 :: Game) ->+ andThen (comeback g) g2 =~= subgame g lose g2)+ , ( "rewardThen r g = andThen (reward r) g"+ , property $+ \ (g :: Game) (r :: Reward) ->+ rewardThen r g =~= andThen (reward r) g)+ , ( "both g (comeback g) = andThen g lose"+ , property $+ \ (g :: Game) ->+ both g (comeback g) =~= andThen g lose)+ , ( "rewardThen r g = both g (reward r)"+ , property $+ \ (g :: Game) (r :: Reward) ->+ rewardThen r g =~= both g (reward r))+ , ( "eitherG g (comeback g) = subgame g win win"+ , property $+ \ (g :: Game) ->+ eitherG g (comeback g) =~= subgame g win win)+ , ( "race g (comeback g) = g"+ , property $+ \ (g :: Game) -> race g (comeback g) =~= g)+ , ( "race (reward r) g = eitherG g (reward r)"+ , property $+ \ (g :: Game) (r :: Reward) ->+ race (reward r) g =~= eitherG g (reward r))+ , ( "gate ef (comeback g) = comeback (gate ef g)"+ , property $+ \ (ef :: EventFilter) (g :: Game) ->+ gate ef (comeback g) =~= comeback (gate ef g))+ , ( "rewardThen r (comeback g) = comeback (rewardThen r g)"+ , property $+ \ (g :: Game) (r :: Reward) ->+ rewardThen r (comeback g) =~= comeback (rewardThen r g))+ , ( "comeback (andThen g bottom) = subgame g bottom win"+ , property $+ \ (g :: Game) ->+ comeback (andThen g bottom) =~= subgame g bottom win)+ , ( "comeback (andThen g lose) = subgame g win win"+ , property $+ \ (g :: Game) ->+ comeback (andThen g lose) =~= subgame g win win)+ , ( "comeback (both g lose) = eitherG g win"+ , property $+ \ (g :: Game) ->+ comeback (both g lose) =~= eitherG g win)+ , ( "comeback (eitherG g bottom) = subgame g lose bottom"+ , property $+ \ (g :: Game) ->+ comeback (eitherG g bottom) =~= subgame g lose bottom)+ , ( "both lose (comeback g) = both g lose"+ , property $+ \ (g :: Game) ->+ both lose (comeback g) =~= both g lose)+ , ( "both lose (multigate xs) = lose"+ , property $+ \ (xs :: [(EventFilter, Game)]) ->+ both lose (multigate xs) =~= lose)+ , ( "race (comeback g) lose = comeback (race g win)"+ , property $+ \ (g :: Game) ->+ race (comeback g) lose =~= comeback (race g win))+ , ( "race (multigate xs) lose = lose"+ , property $+ \ (xs :: [(EventFilter, Game)]) ->+ race (multigate xs) lose =~= lose)+ , ( "race (multigate xs) win = win"+ , property $+ \ (xs :: [(EventFilter, Game)]) ->+ race (multigate xs) win =~= win)+ , ( "andThen (andThen g g2) g3 = andThen g (andThen g2 g3)"+ , property $+ \ (g :: Game) (g2 :: Game) (g3 :: Game) ->+ andThen (andThen g g2) g3 =~= andThen g (andThen g2 g3))+ , ( "both (both g g2) g3 = both g (both g2 g3)"+ , property $+ \ (g :: Game) (g2 :: Game) (g3 :: Game) ->+ both (both g g2) g3 =~= both g (both g2 g3))+ , ( "eitherG g (andThen g g) = g"+ , property $+ \ (g :: Game) -> eitherG g (andThen g g) =~= g)+ , ( "eitherG g (both g g2) = both g (eitherG g g2)"+ , property $+ \ (g :: Game) (g2 :: Game) ->+ eitherG g (both g g2) =~= both g (eitherG g g2))+ , ( "eitherG (eitherG g g2) g3 = eitherG g (eitherG g2 g3)"+ , property $+ \ (g :: Game) (g2 :: Game) (g3 :: Game) ->+ eitherG (eitherG g g2) g3 =~= eitherG g (eitherG g2 g3))+ , ( "eitherG g (rewardThen r g2) = eitherG g2 (rewardThen r g)"+ , property $+ \ (g :: Game) (g2 :: Game) (r :: Reward) ->+ eitherG g (rewardThen r g2) =~= eitherG g2 (rewardThen r g))+ , ( "race g (andThen g g2) = eitherG g (andThen g g2)"+ , property $+ \ (g :: Game) (g2 :: Game) ->+ race g (andThen g g2) =~= eitherG g (andThen g g2))+ , ( "race g (both g g2) = both g (race g g2)"+ , property $+ \ (g :: Game) (g2 :: Game) ->+ race g (both g g2) =~= both g (race g g2))+ , ( "race g (eitherG g g2) = eitherG g (race g g2)"+ , property $+ \ (g :: Game) (g2 :: Game) ->+ race g (eitherG g g2) =~= eitherG g (race g g2))+ , ( "race g (race g g2) = race g g2"+ , property $+ \ (g :: Game) (g2 :: Game) ->+ race g (race g g2) =~= race g g2)+ , ( "race g (race g2 g) = race g g2"+ , property $+ \ (g :: Game) (g2 :: Game) ->+ race g (race g2 g) =~= race g g2)+ , ( "race g (rewardThen r g) = rewardThen r g"+ , property $+ \ (g :: Game) (r :: Reward) ->+ race g (rewardThen r g) =~= rewardThen r g)+ , ( "race (both g g2) g = both g (race g2 g)"+ , property $+ \ (g :: Game) (g2 :: Game) ->+ race (both g g2) g =~= both g (race g2 g))+ , ( "race (eitherG g g2) g = eitherG g (race g2 g)"+ , property $+ \ (g :: Game) (g2 :: Game) ->+ race (eitherG g g2) g =~= eitherG g (race g2 g))+ , ( "race (race g g2) g3 = race g (race g2 g3)"+ , property $+ \ (g :: Game) (g2 :: Game) (g3 :: Game) ->+ race (race g g2) g3 =~= race g (race g2 g3))+ , ( "race (rewardThen r g) g2 = race g (rewardThen r g2)"+ , property $+ \ (g :: Game) (g2 :: Game) (r :: Reward) ->+ race (rewardThen r g) g2 =~= race g (rewardThen r g2))+ , ( "gate ef (andThen g g2) = andThen (gate ef g) g2"+ , property $+ \ (ef :: EventFilter) (g :: Game) (g2 :: Game) ->+ gate ef (andThen g g2) =~= andThen (gate ef g) g2)+ , ( "subgame (comeback g) g2 g3 = subgame g g3 g2"+ , property $+ \ (g :: Game) (g2 :: Game) (g3 :: Game) ->+ subgame (comeback g) g2 g3 =~= subgame g g3 g2)+ , ( "subgame (reward r) g g2 = rewardThen r g"+ , property $+ \ (g :: Game) (g2 :: Game) (r :: Reward) ->+ subgame (reward r) g g2 =~= rewardThen r g)+ , ( "comeback (subgame g g2 win) = andThen g (comeback g2)"+ , property $+ \ (g :: Game) (g2 :: Game) ->+ comeback (subgame g g2 win) =~= andThen g (comeback g2))+ , ( "andThen g (both g lose) = andThen g lose"+ , property $+ \ (g :: Game) ->+ andThen g (both g lose) =~= andThen g lose)+ , ( "andThen g (eitherG g2 win) = eitherG g (andThen g g2)"+ , property $+ \ (g :: Game) (g2 :: Game) ->+ andThen g (eitherG g2 win) =~= eitherG g (andThen g g2))+ , ( "andThen g (race g2 win) = race (andThen g g2) g"+ , property $+ \ (g :: Game) (g2 :: Game) ->+ andThen g (race g2 win) =~= race (andThen g g2) g)+ , ( "andThen (eitherG g bottom) g2 = subgame g g2 bottom"+ , property $+ \ (g :: Game) (g2 :: Game) ->+ andThen (eitherG g bottom) g2 =~= subgame g g2 bottom)+ , ( "andThen (eitherG g win) g = g"+ , property $+ \ (g :: Game) -> andThen (eitherG g win) g =~= g)+ , ( "andThen (race g g2) lose = andThen (race g2 g) lose"+ , property $+ \ (g :: Game) (g2 :: Game) ->+ andThen (race g g2) lose =~= andThen (race g2 g) lose)+ , ( "andThen (race g lose) g = race g lose"+ , property $+ \ (g :: Game) ->+ andThen (race g lose) g =~= race g lose)+ , ( "andThen (race g win) g = g"+ , property $+ \ (g :: Game) -> andThen (race g win) g =~= g)+ , ( "both g (eitherG g2 win) = andThen (eitherG g2 win) g"+ , property $+ \ (g :: Game) (g2 :: Game) ->+ both g (eitherG g2 win) =~= andThen (eitherG g2 win) g)+ , ( "both lose (eitherG g g2) = both g (both g2 lose)"+ , property $+ \ (g :: Game) (g2 :: Game) ->+ both lose (eitherG g g2) =~= both g (both g2 lose))+ , ( "both lose (race g g2) = both g (both g2 lose)"+ , property $+ \ (g :: Game) (g2 :: Game) ->+ both lose (race g g2) =~= both g (both g2 lose))+ , ( "both lose (gate ef g) = lose"+ , property $+ \ (ef :: EventFilter) (g :: Game) ->+ both lose (gate ef g) =~= lose)+ , ( "both (comeback g) (comeback g2) = comeback (eitherG g g2)"+ , property $+ \ (g :: Game) (g2 :: Game) ->+ both (comeback g) (comeback g2) =~= comeback (eitherG g g2))+ , ( "eitherG g (both g2 lose) = andThen (eitherG g2 win) g"+ , property $+ \ (g :: Game) (g2 :: Game) ->+ eitherG g (both g2 lose) =~= andThen (eitherG g2 win) g)+ , ( "race g (andThen g2 bottom) = both g (race g g2)"+ , property $+ \ (g :: Game) (g2 :: Game) ->+ race g (andThen g2 bottom) =~= both g (race g g2))+ , ( "race g (eitherG g2 bottom) = eitherG g (race g g2)"+ , property $+ \ (g :: Game) (g2 :: Game) ->+ race g (eitherG g2 bottom) =~= eitherG g (race g g2))+ , ( "race (comeback g) (comeback g2) = comeback (race g g2)"+ , property $+ \ (g :: Game) (g2 :: Game) ->+ race (comeback g) (comeback g2) =~= comeback (race g g2))+ , ( "race (andThen g g) lose = race g lose"+ , property $+ \ (g :: Game) ->+ race (andThen g g) lose =~= race g lose)+ , ( "race (andThen g g) win = race g win"+ , property $+ \ (g :: Game) ->+ race (andThen g g) win =~= race g win)+ , ( "race (andThen g bottom) g2 = both g2 (race g g2)"+ , property $+ \ (g :: Game) (g2 :: Game) ->+ race (andThen g bottom) g2 =~= both g2 (race g g2))+ , ( "race (eitherG g bottom) g2 = eitherG g2 (race g g2)"+ , property $+ \ (g :: Game) (g2 :: Game) ->+ race (eitherG g bottom) g2 =~= eitherG g2 (race g g2))+ , ( "race (gate ef g) lose = lose"+ , property $+ \ (ef :: EventFilter) (g :: Game) ->+ race (gate ef g) lose =~= lose)+ , ( "race (gate ef g) win = win"+ , property $+ \ (ef :: EventFilter) (g :: Game) ->+ race (gate ef g) win =~= win)+ , ( "gate ef (eitherG g bottom) = eitherG bottom (gate ef g)"+ , property $+ \ (ef :: EventFilter) (g :: Game) ->+ gate ef (eitherG g bottom) =~= eitherG bottom (gate ef g))+ , ( "subgame g bottom (comeback g2) = comeback (subgame g bottom g2)"+ , property $+ \ (g :: Game) (g2 :: Game) ->+ subgame g bottom (comeback g2) =~= comeback (subgame g bottom g2))+ , ( "eitherG bottom (andThen g lose) = subgame g bottom bottom"+ , property $+ \ (g :: Game) ->+ eitherG bottom (andThen g lose) =~= subgame g bottom bottom)+ ]+
+ src/ADD/Tiles/Basic.hs view
@@ -0,0 +1,360 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE ViewPatterns #-}++{-# OPTIONS_GHC -Wall #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module ADD.Tiles.Basic+ ( -- * Tiles and their observations+ Tile ()+ , rasterize+ , rasterize'+ , toImage++ -- * Tile constructors+ , empty+ , color+ , cw+ , ccw+ , flipH+ , flipV+ , beside+ , rows+ , above+ , cols+ , behind+ , quad+ , swirl+ , nona++ -- * Special tiles+ , haskell+ , sandy++ -- * Colors and their observations+ , Color+ , redChannel+ , greenChannel+ , blueChannel+ , alphaChannel++ -- * Color constructors+ , pattern Color+ , invert+ , mask+ , over+ ) where++import Codec.Picture.Png+import Codec.Picture.Types+import Control.Applicative hiding (empty)+import Data.Coerce+import Data.FileEmbed+import Data.Functor.Compose+import Data.Word+import Test.QuickCheck hiding (label)+++------------------------------------------------------------------------------++type Color = PixelRGBA8++instance Semigroup Color where+ (<>) = over++instance Monoid Color where+ mempty = Color 0 0 0 0++color :: Double -> Double -> Double -> Double -> Tile+color r g b a = Tile $ const $ const $ _rgba r g b a++------------------------------------------------------------------------------+-- | Extract the red channel from a 'Color'.+redChannel :: Color -> Double+redChannel (Color r _ _ _) = r++------------------------------------------------------------------------------+-- | Extract the green channel from a 'Color'.+greenChannel :: Color -> Double+greenChannel (Color _ g _ _) = g++------------------------------------------------------------------------------+-- | Extract the blue channel from a 'Color'.+blueChannel :: Color -> Double+blueChannel (Color _ _ b _) = b++------------------------------------------------------------------------------+-- | Extract the alpha channel from a 'Color'.+alphaChannel :: Color -> Double+alphaChannel (Color _ _ _ a) = a++------------------------------------------------------------------------------+-- | Inverts a 'Color' by negating each of its color channels, but leaving the+-- alpha alone.+invert :: Color -> Color+invert (Color r g b a) = Color (1 - r) (1 - g) (1 - b) a+++_rgba :: Double -> Double -> Double -> Double -> Color+_rgba r g b a =+ PixelRGBA8+ (bounded r)+ (bounded g)+ (bounded b)+ (bounded a)+ where+ bounded :: Double -> Word8+ bounded x = round $ x * fromIntegral (maxBound @Word8)++------------------------------------------------------------------------------+-- |+pattern Color :: Double -> Double -> Double -> Double -> Color+pattern Color r g b a <-+ PixelRGBA8+ (fromIntegral -> (/255) -> r)+ (fromIntegral -> (/255) -> g)+ (fromIntegral -> (/255) -> b)+ (fromIntegral -> (/255) -> a)+ where+ Color = _rgba+{-# COMPLETE Color #-}++instance Semigroup Tile where+ (<>) = behind++instance Monoid Tile where+ mempty = mempty+++newtype Tile = Tile+ { runTile :: Double -> Double -> Color+ }++instance Show Tile where+ show _ = "<tile>"++instance Arbitrary Tile where+ arbitrary = Tile <$> arbitrary++instance CoArbitrary PixelRGBA8 where+ coarbitrary (Color r g b a) = coarbitrary (r, g, b, a)++instance Arbitrary PixelRGBA8 where+ arbitrary = PixelRGBA8 <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary++------------------------------------------------------------------------------+-- | Rotate a 'Tile' clockwise.+cw :: Tile -> Tile+cw (Tile f) = Tile $ \x y -> f y (1 - x)+++------------------------------------------------------------------------------+-- | Rotate a 'Tile' counterclockwise.+ccw :: Tile -> Tile+ccw (Tile f) = Tile $ \x y -> f (1 - y) x++_fromImage :: Image PixelRGBA8 -> Tile+_fromImage img@(Image w h _) = Tile $ \x y ->+ pixelAt+ img+ (max 0 (min (w - 1) (floor $ x * fromIntegral w)))+ (max 0 (min (h - 1) (floor $ y * fromIntegral h)))+++------------------------------------------------------------------------------+-- | Place the first 'Tile' to the left of the second. Each 'Tile' will receive+-- half of the available width, but keep their full height.+beside :: Tile -> Tile -> Tile+beside (Tile a) (Tile b) = Tile $ \x y ->+ case x >= 0.5 of+ False -> a (2 * x) y+ True -> b (2 * (x - 0.5)) y+++------------------------------------------------------------------------------+-- | Place the first 'Tile' above the second. Each 'Tile' will receive half of+-- the available height, but keep their full width.+above :: Tile -> Tile -> Tile+above (Tile a) (Tile b) = Tile $ \x y ->+ case y >= 0.5 of+ False -> a x (2 * y)+ True -> b x (2 * (y - 0.5))+++------------------------------------------------------------------------------+-- | Place the first 'Tile' behind the second. The result of this operation is+-- for transparent or semi-transparent pixels in the second argument to be+-- blended via 'over' with those in the first.+behind :: Tile -> Tile -> Tile+behind (Tile a) (Tile b) = Tile $ \x y -> flip over (a x y) (b x y)+++------------------------------------------------------------------------------+-- | Mirror a 'Tile' horizontally.+flipH :: Tile -> Tile+flipH (Tile t) = Tile $ \x y ->+ t (1 - x) y+++------------------------------------------------------------------------------+-- | Mirror a 'Tile' vertically.+flipV :: Tile -> Tile+flipV (Tile t) = Tile $ \x y ->+ t x (1 - y)+++------------------------------------------------------------------------------+-- | The empty, fully transparent 'Tile'.+empty :: Tile+empty = mempty+++------------------------------------------------------------------------------+-- | Like 'above', but repeated. Every element in the list will take up+-- a proportional height of the resulting 'Tile'.+rows :: [Tile] -> Tile+rows [] = mempty+rows ts =+ let n = length ts+ in Tile $ \x y ->+ let i = floor $ fromIntegral n * y+ in runTile (ts !! i) x y+++------------------------------------------------------------------------------+-- | Like 'beside', but repeated. Every element in the list will take up+-- a proportional width of the resulting 'Tile'.+cols :: [Tile] -> Tile+cols [] = mempty+cols ts =+ let n = length ts+ in Tile $ \x y ->+ let i = floor $ fromIntegral n * x+ in runTile (ts !! i) x y+++------------------------------------------------------------------------------+-- | Place four 'Tile's in the four quadrants. The first argument is the+-- top-left; the second is the top-right; third: bottom left; fourth: bottom+-- right.+quad :: Tile -> Tile -> Tile -> Tile -> Tile+quad a b c d = (a `beside` b) `above` (c `beside` d)+++------------------------------------------------------------------------------+-- | A 'quad' where the given 'Tile' is rotated via 'cw' once more per+-- quadrant.+swirl :: Tile -> Tile+swirl t = quad t (cw t) (ccw t) $ cw $ cw t+++------------------------------------------------------------------------------+-- | Puts a frame around a 'Tile'. The first argument is the straight-edge+-- border for the top of the frame. The second argument should be for the+-- top-right corner. The third argument is the 'Tile' that should be framed.+nona :: Tile -> Tile -> Tile -> Tile+nona t tr c =+ rows [ cols [ ccw tr, t, tr ]+ , cols [ ccw t, c, cw t ]+ , cols [ cw (cw tr), cw $ cw t, cw tr ]+ ]++------------------------------------------------------------------------------+-- | Blends a 'Color' using standard alpha compositing.+over :: Color -> Color -> Color+over (PixelRGBA8 r1 g1 b1 a1) (PixelRGBA8 r2 g2 b2 a2) =+ let aa = norm a1+ ab = norm a2+ a' = aa + ab * (1 - aa)+ norm :: Word8 -> Double+ norm x = fromIntegral x / 255+ unnorm :: Double -> Word8+ unnorm x = round $ x * 255+ f :: Word8 -> Word8 -> Word8+ f a b = unnorm $ (norm a * aa + norm b * ab * (1 - aa)) / a'+ in+ PixelRGBA8 (f r1 r2) (f g1 g2) (f b1 b2) (unnorm a')+++------------------------------------------------------------------------------+-- | Copy the alpha channel from the first 'Color' and the color channels from+-- the second 'Color'.+mask :: Color -> Color -> Color+mask (PixelRGBA8 _ _ _ a) (PixelRGBA8 r g b _) = PixelRGBA8 r g b a+++--------------------------------------------------------------------------------++------------------------------------------------------------------------------+-- | Like 'rasterize', but into a format that can be directly saved to disk as+-- an image.+toImage+ :: Int -- ^ resulting width+ -> Int -- ^ resulting height+ -> Tile+ -> Image PixelRGBA8+toImage w h (Tile t) = generateImage f w h+ where+ coord :: Int -> Int -> Double+ coord dx x = fromIntegral dx / fromIntegral x+ f :: Int -> Int -> PixelRGBA8+ f x y = t (coord x w) (coord y h)+++------------------------------------------------------------------------------+-- | The Haskell logo.+haskell :: Tile+haskell =+ let Right (ImageRGBA8 img) = decodePng $(embedFile "static/haskell.png")+ in _fromImage img++------------------------------------------------------------------------------+-- | Sandy.+sandy :: Tile+sandy =+ let Right (ImageRGBA8 img) = decodePng $(embedFile "static/sandy.png")+ in _fromImage img+++------------------------------------------------------------------------------+-- | Rasterize a 'Tile' down into a row-major representation of its constituent+-- "pixels". For a version that emits a list of lists directly, see 'rasterize''.+rasterize+ :: Int -- ^ resulting width+ -> Int -- ^ resulting heigeht+ -> Tile+ -> Compose ZipList ZipList Color -- ^ the resulting "pixels" in row-major order+rasterize w h (Tile t) = coerce $ do+ y <- [0 .. (h - 1)]+ pure $ do+ x <- [0 .. (w - 1)]+ pure $ f x y++ where+ coord :: Int -> Int -> Double+ coord dx x = fromIntegral dx / fromIntegral x++ f :: Int -> Int -> Color+ f x y = t (coord x w) (coord y h)++------------------------------------------------------------------------------+-- | Like 'rasterize', but with a more convenient output type.+rasterize'+ :: Int -- ^ resulting width+ -> Int -- ^ resulting heigeht+ -> Tile+ -> [[Color]] -- ^ the resulting "pixels" in row-major order+rasterize' w h t = coerce $ rasterize w h t+
+ src/ADD/Tiles/Functor.hs view
@@ -0,0 +1,379 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE ViewPatterns #-}++{-# OPTIONS_GHC -Wall #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module ADD.Tiles.Functor+ ( -- * Tiles and their observations+ Tile ()+ , rasterize+ , rasterize'+ , toImage++ -- * Tile constructors+ , empty+ , color+ , cw+ , ccw+ , flipH+ , flipV+ , beside+ , rows+ , above+ , cols+ , behind+ , quad+ , quads+ , swirl+ , nona++ -- * Special tiles+ , haskell+ , sandy++ -- * Colors and their observations+ , Color+ , redChannel+ , greenChannel+ , blueChannel+ , alphaChannel++ -- * Color constructors+ , pattern Color+ , invert+ , mask+ , over+ ) where++import Codec.Picture.Png+import Codec.Picture.Types+import Control.Applicative hiding (empty)+import Data.Coerce+import Data.FileEmbed+import Data.Functor.Compose+import Data.Word+import Test.QuickCheck hiding (label)+++------------------------------------------------------------------------------++type Color = PixelRGBA8++instance Semigroup Color where+ (<>) = over++instance Monoid Color where+ mempty = Color 0 0 0 0++color :: Double -> Double -> Double -> Double -> Tile Color+color r g b a = pure $ _rgba r g b a++------------------------------------------------------------------------------+-- | Extract the red channel from a 'Color'.+redChannel :: Color -> Double+redChannel (Color r _ _ _) = r++------------------------------------------------------------------------------+-- | Extract the green channel from a 'Color'.+greenChannel :: Color -> Double+greenChannel (Color _ g _ _) = g++------------------------------------------------------------------------------+-- | Extract the blue channel from a 'Color'.+blueChannel :: Color -> Double+blueChannel (Color _ _ b _) = b++------------------------------------------------------------------------------+-- | Extract the alpha channel from a 'Color'.+alphaChannel :: Color -> Double+alphaChannel (Color _ _ _ a) = a++------------------------------------------------------------------------------+-- | Inverts a 'Color' by negating each of its color channels, but leaving the+-- alpha alone.+invert :: Color -> Color+invert (Color r g b a) = Color (1 - r) (1 - g) (1 - b) a+++_rgba :: Double -> Double -> Double -> Double -> Color+_rgba r g b a =+ PixelRGBA8+ (bounded r)+ (bounded g)+ (bounded b)+ (bounded a)+ where+ bounded :: Double -> Word8+ bounded x = round $ x * fromIntegral (maxBound @Word8)++------------------------------------------------------------------------------+-- |+pattern Color :: Double -> Double -> Double -> Double -> Color+pattern Color r g b a <-+ PixelRGBA8+ (fromIntegral -> (/255) -> r)+ (fromIntegral -> (/255) -> g)+ (fromIntegral -> (/255) -> b)+ (fromIntegral -> (/255) -> a)+ where+ Color = _rgba+{-# COMPLETE Color #-}++instance Semigroup a => Semigroup (Tile a) where+ (<>) = liftA2 (<>)++instance Monoid a => Monoid (Tile a) where+ mempty = pure mempty+++newtype Tile a = Tile+ { runTile :: Double -> Double -> a+ }+ deriving stock (Functor)+ deriving Applicative via (Compose ((->) Double) ((->) Double))++instance Show (Tile t) where+ show _ = "<tile>"++instance Arbitrary a => Arbitrary (Tile a) where+ arbitrary = Tile <$> arbitrary++instance CoArbitrary PixelRGBA8 where+ coarbitrary (Color r g b a) = coarbitrary (r, g, b, a)++instance Arbitrary PixelRGBA8 where+ arbitrary = PixelRGBA8 <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary++instance Monad Tile where+ Tile ma >>= f = Tile $ \x y -> runTile (f (ma x y)) x y++------------------------------------------------------------------------------+-- | Rotate a 'Tile' clockwise.+cw :: Tile a -> Tile a+cw (Tile f) = Tile $ \x y -> f y (1 - x)+++------------------------------------------------------------------------------+-- | Rotate a 'Tile' counterclockwise.+ccw :: Tile a -> Tile a+ccw (Tile f) = Tile $ \x y -> f (1 - y) x++_fromImage :: Image PixelRGBA8 -> Tile Color+_fromImage img@(Image w h _) = Tile $ \x y ->+ pixelAt+ img+ (max 0 (min (w - 1) (floor $ x * fromIntegral w)))+ (max 0 (min (h - 1) (floor $ y * fromIntegral h)))+++------------------------------------------------------------------------------+-- | Place the first 'Tile' to the left of the second. Each 'Tile' will receive+-- half of the available width, but keep their full height.+beside :: Tile a -> Tile a -> Tile a+beside (Tile a) (Tile b) = Tile $ \x y ->+ case x >= 0.5 of+ False -> a (2 * x) y+ True -> b (2 * (x - 0.5)) y+++------------------------------------------------------------------------------+-- | Place the first 'Tile' above the second. Each 'Tile' will receive half of+-- the available height, but keep their full width.+above :: Tile a -> Tile a -> Tile a+above (Tile a) (Tile b) = Tile $ \x y ->+ case y >= 0.5 of+ False -> a x (2 * y)+ True -> b x (2 * (y - 0.5))+++------------------------------------------------------------------------------+-- | Place the first 'Tile' behind the second. The result of this operation is+-- for transparent or semi-transparent pixels in the second argument to be+-- blended via 'over' with those in the first.+behind :: Tile Color -> Tile Color -> Tile Color+behind = flip (liftA2 over)+++------------------------------------------------------------------------------+-- | Mirror a 'Tile' horizontally.+flipH :: Tile a -> Tile a+flipH (Tile t) = Tile $ \x y ->+ t (1 - x) y+++------------------------------------------------------------------------------+-- | Mirror a 'Tile' vertically.+flipV :: Tile a -> Tile a+flipV (Tile t) = Tile $ \x y ->+ t x (1 - y)+++------------------------------------------------------------------------------+-- | The empty, fully transparent 'Tile'.+empty :: Tile Color+empty = pure mempty+++------------------------------------------------------------------------------+-- | Like 'above', but repeated. Every element in the list will take up+-- a proportional height of the resulting 'Tile'.+rows :: Monoid a => [Tile a] -> Tile a+rows [] = mempty+rows ts =+ let n = length ts+ in Tile $ \x y ->+ let i = floor $ fromIntegral n * y+ in runTile (ts !! i) x y+++------------------------------------------------------------------------------+-- | Like 'beside', but repeated. Every element in the list will take up+-- a proportional width of the resulting 'Tile'.+cols :: Monoid a => [Tile a] -> Tile a+cols [] = mempty+cols ts =+ let n = length ts+ in Tile $ \x y ->+ let i = floor $ fromIntegral n * x+ in runTile (ts !! i) x y+++------------------------------------------------------------------------------+-- | Place four 'Tile's in the four quadrants. The first argument is the+-- top-left; the second is the top-right; third: bottom left; fourth: bottom+-- right.+quad :: Tile a -> Tile a -> Tile a -> Tile a -> Tile a+quad a b c d = (a `beside` b) `above` (c `beside` d)++------------------------------------------------------------------------------+-- | Like `quad`, but constructs a 'Tile' of endomorphisms. The given function+-- is called one more time for each quadrant, starting clockwise from the+-- top-left.+quads :: (a -> a) -> Tile (a -> a)+quads f =+ quad+ (pure id)+ (pure f)+ (pure $ f . f . f)+ (pure $ f . f)+++------------------------------------------------------------------------------+-- | A 'quad' where the given 'Tile' is rotated via 'cw' once more per+-- quadrant.+swirl :: Tile a -> Tile a+swirl t = quad t (cw t) (ccw t) $ cw $ cw t+++------------------------------------------------------------------------------+-- | Puts a frame around a 'Tile'. The first argument is the straight-edge+-- border for the top of the frame. The second argument should be for the+-- top-right corner. The third argument is the 'Tile' that should be framed.+nona :: Monoid a => Tile a -> Tile a -> Tile a -> Tile a+nona t tr c =+ rows [ cols [ ccw tr, t, tr ]+ , cols [ ccw t, c, cw t ]+ , cols [ cw (cw tr), cw $ cw t, cw tr ]+ ]++------------------------------------------------------------------------------+-- | Blends a 'Color' using standard alpha compositing.+over :: Color -> Color -> Color+over (PixelRGBA8 r1 g1 b1 a1) (PixelRGBA8 r2 g2 b2 a2) =+ let aa = norm a1+ ab = norm a2+ a' = aa + ab * (1 - aa)+ norm :: Word8 -> Double+ norm x = fromIntegral x / 255+ unnorm :: Double -> Word8+ unnorm x = round $ x * 255+ f :: Word8 -> Word8 -> Word8+ f a b = unnorm $ (norm a * aa + norm b * ab * (1 - aa)) / a'+ in+ PixelRGBA8 (f r1 r2) (f g1 g2) (f b1 b2) (unnorm a')+++------------------------------------------------------------------------------+-- | Copy the alpha channel from the first 'Color' and the color channels from+-- the second 'Color'.+mask :: Color -> Color -> Color+mask (PixelRGBA8 _ _ _ a) (PixelRGBA8 r g b _) = PixelRGBA8 r g b a+++--------------------------------------------------------------------------------++------------------------------------------------------------------------------+-- | Like 'rasterize', but into a format that can be directly saved to disk as+-- an image.+toImage+ :: Int -- ^ resulting width+ -> Int -- ^ resulting height+ -> Tile Color+ -> Image PixelRGBA8+toImage w h (Tile t) = generateImage f w h+ where+ coord :: Int -> Int -> Double+ coord dx x = fromIntegral dx / fromIntegral x+ f :: Int -> Int -> PixelRGBA8+ f x y = t (coord x w) (coord y h)+++------------------------------------------------------------------------------+-- | The Haskell logo.+haskell :: Tile Color+haskell =+ let Right (ImageRGBA8 img) = decodePng $(embedFile "static/haskell.png")+ in _fromImage img++------------------------------------------------------------------------------+-- | Sandy.+sandy :: Tile Color+sandy =+ let Right (ImageRGBA8 img) = decodePng $(embedFile "static/sandy.png")+ in _fromImage img+++------------------------------------------------------------------------------+-- | Rasterize a 'Tile' down into a row-major representation of its constituent+-- "pixels". For a version that emits a list of lists directly, see 'rasterize''.+rasterize+ :: forall a+ . Int -- ^ resulting width+ -> Int -- ^ resulting heigeht+ -> Tile a+ -> Compose ZipList ZipList a -- ^ the resulting "pixels" in row-major order+rasterize w h (Tile t) = coerce $ do+ y <- [0 .. (h - 1)]+ pure $ do+ x <- [0 .. (w - 1)]+ pure $ f x y++ where+ coord :: Int -> Int -> Double+ coord dx x = fromIntegral dx / fromIntegral x++ f :: Int -> Int -> a+ f x y = t (coord x w) (coord y h)++------------------------------------------------------------------------------+-- | Like 'rasterize', but with a more convenient output type.+rasterize'+ :: Int -- ^ resulting width+ -> Int -- ^ resulting heigeht+ -> Tile a+ -> [[a]] -- ^ the resulting "pixels" in row-major order+rasterize' w h t = coerce $ rasterize w h t+