diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for algebra-driven-design + +## Unreleased changes diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,1 @@ +# algebra-driven-design diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/algebra-driven-design.cabal b/algebra-driven-design.cabal new file mode 100644 --- /dev/null +++ b/algebra-driven-design.cabal @@ -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 +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 diff --git a/src/ADD/Games/Basic.hs b/src/ADD/Games/Basic.hs new file mode 100644 --- /dev/null +++ b/src/ADD/Games/Basic.hs @@ -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 + ] + diff --git a/src/ADD/Games/Correct.hs b/src/ADD/Games/Correct.hs new file mode 100644 --- /dev/null +++ b/src/ADD/Games/Correct.hs @@ -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) + ] + diff --git a/src/ADD/Tiles/Basic.hs b/src/ADD/Tiles/Basic.hs new file mode 100644 --- /dev/null +++ b/src/ADD/Tiles/Basic.hs @@ -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 _ = "" + +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 new file mode 100644 --- /dev/null +++ b/src/ADD/Tiles/Functor.hs @@ -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 _ = "" + +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 +