diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Jeffrey Rosenbluth name here (c) 2017 + +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 Author name here 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,116 @@ +# wallpaper +## Symmetry Patterns +Create wallpaper patterns using the domain coloring algorithm as described in +[Creating Symmetry], by Frank A. Farris, (c) 2015 Princeton University Press. + +The api is likely to change as this is still an alpha release. + +[Creating Symmetry]: https://www.amazon.com/Creating-Symmetry-Mathematics-Wallpaper-Patterns/dp/0691161739/ref=sr_1_1?ie=UTF8&qid=1495813829&sr=8-1&keywords=creating+symmetry + +## Installation +Install [stack](https://docs.haskellstack.org/en/stable/README/) + +``` +git clone https://github.com/jeffreyrosenbluth/wallpaper.git +cd wallpaper +stack build +stack exec wallpaper myWallpaper.yaml +-- or +stack exec rosette myRosette.yaml +``` + +### Wallpaper and Frieze +![example](https://github.com/jeffreyrosenbluth/wallpaper/blob/master/myWallpaper.jpg) + +To make a wallpaper or frieze image, run the wallpaper function with a yaml +file like the following. There are many [examples]. + +[examples]: https://github.com/jeffreyrosenbluth/wallpaper/tree/master/examples + +```yaml +# The wallpaper or frieze symmetry group in short IUC notation. +# If the group lattice takes parameters then they follow tagged +# by there names, for example: +# Group: +# Name: p1 +# xi: 1.5 +# eta: 2.1 +# If the group lattice takes no parameters you can use either +# Group: +# Name: p4 +# or, just directly: +# Group: p4 +Group: p3m1 + +# A list of doubly indexed complex coefficients for the wave function. +# Additional wave packets will be added in order to create the symmetries in +# the specified symmetry group. +Coefficients: +- A(n,m): [0.75, 0.25] # 0.75 + 0.25i + n: 1 # first index of coefficient + m: 0 # second index of coefficient +- A(n,m): [0.2, -0.2] + n: -2 + m: 2 +- A(n,m): [0.6, 0.1] + n: 1 + m: -1 + +# Optional field for setting the style, choices are: plain, morph (which takes +# one parameter: cutoff), and blend (which takes as an argument a group object). +# morph will interpolate between the color wheel and its 180 degree rotation, +# leaving the proportion specified by cutoff at the beginning and end. +# Blend interpolates horizontally between two different wallpaper groups. +# If left unspecified type will default to style: plain. +Type: + style: blend + group: + name: p31m + +Options: + width: 945 # width in pixels of the output image + height: 405 # height in pixels of the output image + repeat-length: 90 # used to convert pixel coordinates to real numbers + scale-factor: 0.5 # to scale the color wheel so that it contains the domain values + +# Optional, defaults to the standard artists color wheel of infinite size. +Colorwheel-path: examples/rose_small.png + +# Optional, Preprocess the image, choices are: none, fliphorizontal, +# flipvertical, flipboth, invert, antisymmvertical, and antisymmhorizontal. +# The default is none. +Pre-process: AntiSymmHorizontal + +# File to write the result. The file type will match the extension. +# Choices for extenstion are: png, jpg, tif, and bmp. +Output-path: myWallpaper.jpg +``` + +### Rosette + +![example](https://github.com/jeffreyrosenbluth/wallpaper/blob/master/myRosette.jpg) + +To make a rosette, use a yaml file like the following. There are also some +[examples], look at rosetteP.yaml and rosettePM.yaml. + +```yaml +P-fold: 5 # the number of rotational symmetries +Mirror: true # symmetric about the horizontal axis + +# (n - m) mod P-fold must be 0, otherwise the wave packet will not be included. +Coefficients: +- A(n,m): [0.5, 0] + n: 5 # (5 - 0) mod 5 = 0 + m: 0 +- A(n,m): [0.3, 0] + n: 4 # (4 - (-6)) mod 5 = 0 + m: -6 +Options: + width: 540 + height: 540 + repeat-length: 135 + scale-factor: 0.5 +Colorwheel-path: examples/rose_small.png +Pre-process: invert +Output-path: myRosette.jpg +``` 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/app/Rosette.hs b/app/Rosette.hs new file mode 100644 --- /dev/null +++ b/app/Rosette.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module Main where + +import Portrait +import Types + +import Data.Complex +import Data.Yaml (ParseException, decodeFileEither) +import System.Environment + +main :: IO () +main = do + [yamlFile] <- getArgs + (rs :: Either ParseException (Rosette Double)) <- decodeFileEither yamlFile + case rs of + Left e -> error (show e) + Right r -> rosette' r + +coefs :: [Coef Double] +coefs = [ Coef 1 0 (0.75:+0.25) + , Coef (-2) 2 (0.2:+(-0.2)) + , Coef 1 (-1) (0.6:+0.1) + ] + +rosette' :: RealFloat a => Rosette a -> IO () +rosette' rs = rosette (rsOptions rs) + (rsCoefs rs) + (rsFoldSym rs) + (rsMirror rs) + (rsProcess rs) + (rsWheel rs) + (rsPath rs) diff --git a/app/Wallpaper.hs b/app/Wallpaper.hs new file mode 100644 --- /dev/null +++ b/app/Wallpaper.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module Main where + +import Portrait +import Types + +import Data.Yaml (ParseException, decodeFileEither) +import System.Environment + +main :: IO () +main = do + [yamlFile] <- getArgs + (wp :: Either ParseException (Wallpaper Double)) <- decodeFileEither yamlFile + case wp of + Left e -> error (show e) + Right w -> wallpaper w + +wallpaper :: RealFloat a => Wallpaper a -> IO () +wallpaper wp = pattern (wpOptions wp) + (recipe (wpGroup wp)) + (wpCoefs wp) + (wpType wp) + (wpProcess wp) + (wpWheel wp) + (wpPath wp) diff --git a/examples/Y.png b/examples/Y.png new file mode 100644 Binary files /dev/null and b/examples/Y.png differ diff --git a/examples/beach_morph.png b/examples/beach_morph.png new file mode 100644 Binary files /dev/null and b/examples/beach_morph.png differ diff --git a/examples/cm.png b/examples/cm.png new file mode 100644 Binary files /dev/null and b/examples/cm.png differ diff --git a/examples/cmm.png b/examples/cmm.png new file mode 100644 Binary files /dev/null and b/examples/cmm.png differ diff --git a/examples/colorwheel.png b/examples/colorwheel.png new file mode 100644 Binary files /dev/null and b/examples/colorwheel.png differ diff --git a/examples/morph.png b/examples/morph.png new file mode 100644 Binary files /dev/null and b/examples/morph.png differ diff --git a/examples/p1.png b/examples/p1.png new file mode 100644 Binary files /dev/null and b/examples/p1.png differ diff --git a/examples/p111.png b/examples/p111.png new file mode 100644 Binary files /dev/null and b/examples/p111.png differ diff --git a/examples/p11g.png b/examples/p11g.png new file mode 100644 Binary files /dev/null and b/examples/p11g.png differ diff --git a/examples/p11m.png b/examples/p11m.png new file mode 100644 Binary files /dev/null and b/examples/p11m.png differ diff --git a/examples/p1m1.png b/examples/p1m1.png new file mode 100644 Binary files /dev/null and b/examples/p1m1.png differ diff --git a/examples/p2.png b/examples/p2.png new file mode 100644 Binary files /dev/null and b/examples/p2.png differ diff --git a/examples/p211.png b/examples/p211.png new file mode 100644 Binary files /dev/null and b/examples/p211.png differ diff --git a/examples/p2mg.png b/examples/p2mg.png new file mode 100644 Binary files /dev/null and b/examples/p2mg.png differ diff --git a/examples/p2mm.png b/examples/p2mm.png new file mode 100644 Binary files /dev/null and b/examples/p2mm.png differ diff --git a/examples/p3.png b/examples/p3.png new file mode 100644 Binary files /dev/null and b/examples/p3.png differ diff --git a/examples/p31m.png b/examples/p31m.png new file mode 100644 Binary files /dev/null and b/examples/p31m.png differ diff --git a/examples/p3m1.png b/examples/p3m1.png new file mode 100644 Binary files /dev/null and b/examples/p3m1.png differ diff --git a/examples/p4.png b/examples/p4.png new file mode 100644 Binary files /dev/null and b/examples/p4.png differ diff --git a/examples/p4g.png b/examples/p4g.png new file mode 100644 Binary files /dev/null and b/examples/p4g.png differ diff --git a/examples/p4m.png b/examples/p4m.png new file mode 100644 Binary files /dev/null and b/examples/p4m.png differ diff --git a/examples/p6.png b/examples/p6.png new file mode 100644 Binary files /dev/null and b/examples/p6.png differ diff --git a/examples/p6m.png b/examples/p6m.png new file mode 100644 Binary files /dev/null and b/examples/p6m.png differ diff --git a/examples/pg.png b/examples/pg.png new file mode 100644 Binary files /dev/null and b/examples/pg.png differ diff --git a/examples/pgg.png b/examples/pgg.png new file mode 100644 Binary files /dev/null and b/examples/pgg.png differ diff --git a/examples/pm.png b/examples/pm.png new file mode 100644 Binary files /dev/null and b/examples/pm.png differ diff --git a/examples/pmg.png b/examples/pmg.png new file mode 100644 Binary files /dev/null and b/examples/pmg.png differ diff --git a/examples/pmm.png b/examples/pmm.png new file mode 100644 Binary files /dev/null and b/examples/pmm.png differ diff --git a/examples/rose_small.png b/examples/rose_small.png new file mode 100644 Binary files /dev/null and b/examples/rose_small.png differ diff --git a/examples/rosetteP.png b/examples/rosetteP.png new file mode 100644 Binary files /dev/null and b/examples/rosetteP.png differ diff --git a/examples/rosettePM.png b/examples/rosettePM.png new file mode 100644 Binary files /dev/null and b/examples/rosettePM.png differ diff --git a/examples/squares.png b/examples/squares.png new file mode 100644 Binary files /dev/null and b/examples/squares.png differ diff --git a/src/Complextra.hs b/src/Complextra.hs new file mode 100644 --- /dev/null +++ b/src/Complextra.hs @@ -0,0 +1,30 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : Complextra +-- Copyright : (c) 2017 Jeffrey Rosenbluth +-- License : BSD-style (see LICENSE) +-- Maintainer : jeffrey.rosenbluth@gmail.com +-- +-- Utility functions for dealing with complex numbers. +-------------------------------------------------------------------------------- + +module Complextra + ( scaleZ + , (.*^) + , im + ) where + +import Data.Complex + +-- | Multiply a complex number by a real number. +scaleZ :: RealFloat a => a -> Complex a -> Complex a +scaleZ k z = (k :+ 0) * z + +-- | Infix form of 'scaleZ'. +(.*^) :: RealFloat a => a -> Complex a -> Complex a +(.*^) = scaleZ +infixl 7 .*^ + +-- | The square root of -1, i.e. i. +im :: Num a => Complex a +im = 0 :+ 1 diff --git a/src/Core.hs b/src/Core.hs new file mode 100644 --- /dev/null +++ b/src/Core.hs @@ -0,0 +1,128 @@ +{-# LANGUAGE FlexibleContexts #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Core +-- Copyright : (c) 2017 Jeffrey Rosenbluth +-- License : BSD-style (see LICENSE) +-- Maintainer : jeffrey.rosenbluth@gmail.com +-- +-- Tools for creating symmtery images using the domain coloring algortihm. +-- +-- <> +-------------------------------------------------------------------------------- + +module Core + ( + -- * Domain Coloring + domainColoring + , blend + , morph + , mkRecipe + + -- * Coefficients + , negateCoefs + , negateFst + , negateSnd + , reverseCoefs + , alternateCoefs + ) where + +import Complextra +import Types + +import Codec.Picture +import Data.Complex + +-- Domain Coloring ------------------------------------------------------------- +-- | Creates a function to get the color of pixel (i, j) from a color wheel +-- given 'Options', a 'Recipe' and the color wheel. You shouldn't need to +-- use this function directly. +getColor :: (RealFloat a, Pixel p, BlackWhite p) + => Options a -> Recipe a -> Image p -> Int -> Int -> p +getColor opts rcp wheel i j = clamp (round x + w1 `div` 2) (round y + h1 `div` 2) + where + (w1, h1) = (imageWidth wheel, imageHeight wheel) + (x :+ y) = (scale opts * 0.5 * fromIntegral (min w1 h1)) + .*^ focusIn (width opts) + (height opts) + (repLength opts) + rcp + (fromIntegral i :+ fromIntegral j) + clamp m n + | m < 0 || n < 0 || m >= w1 || n >= h1 = black + | otherwise = pixelAt wheel m n + +-- | Center the coordinates at the origin and scale them based on 'repLength' +focusIn :: RealFloat a => Int -> Int -> Int -> Recipe a -> Recipe a +focusIn w h l rcp (x :+ y) = + rcp ((x - fromIntegral w / 2) / l' :+ (fromIntegral h / 2 - y) / l') + where + l' = fromIntegral l + +-- | Make an image from a set of 'Options', a 'Recipe' and a color source. +domainColoring :: (RealFloat a, Pixel p, BlackWhite p) + => Options a -> Recipe a -> ColorSource a p -> Image p +domainColoring opts rcp source = generateImage color (width opts) (height opts) + where + color i j = case source of + Picture img -> getColor opts rcp img i j + Function f -> + let rcp' = focusIn (width opts) (height opts) (repLength opts) rcp + in f . rcp' $ (fromIntegral i :+ fromIntegral j) + +-- | Make a symmetry image from two 'Recipe's by linearly interpolation. +-- The interpolation is along the horizontal axis. +blend :: (RealFloat a, Pixel p, BlackWhite p) + => Options a -> Recipe a -> Recipe a -> ColorSource a p -> Image p +blend opts rcp1 rcp2 = domainColoring opts rcp + where + rcp z@(x :+ _) = let a = (x + m) / (2 * m) + in a .*^ rcp2 z + (1 - a) .*^ rcp1 z + m = max 1 (fromIntegral (width opts) / fromIntegral (height opts)) + +-- | Make a symmetry image by interpolating between a color wheel and its 180 +-- degree rotation. The cutoff represents what percentage of the +-- image stays constant at the left and right sides. Like 'blend' the +-- interpolation is in the horizontal direction. +morph :: (RealFloat a, Pixel p, BlackWhite p) + => Options a -> Recipe a -> a -> ColorSource a p -> Image p +morph opts rcp c = domainColoring opts rcp' + where + rcp' z@(x :+ _) = exp (pi * phi c ((x+t/2)/t) .*^ im) * rcp z + t = fromIntegral (width opts `div`repLength opts) + phi cut u + | u < cut = 1 + | u > 1 - cut = -1 + | otherwise = (2 / (2 * cut - 1)) * (u - 0.5) + +-- | Make a recipe from a lattice and a list of Coefficients. +mkRecipe :: RealFloat a => (Int -> Int -> Recipe a) -> [Coef a] -> Recipe a +mkRecipe rf cs z = sum $ zipWith (*) as rs + where + as = anm <$> cs + rs = ($ z) . uncurry rf <$> [(nCoord c, mCoord c) | c <- cs] + +-- Coefficients ---------------------------------------------------------------- +-- | Negate the indices of a coefficient. +negateCoefs :: Coef a -> Coef a +negateCoefs (Coef n m a) = Coef (-n) (-m) a + +-- | Negate the first index of a coefficient. +negateFst :: Coef a -> Coef a +negateFst (Coef n m a) = Coef (-n) m a + +-- | Negate the second index of a coefficient. +negateSnd :: Coef a -> Coef a +negateSnd (Coef n m a) = Coef n (-m) a + +-- | Reverse the indices of a coefficient. +reverseCoefs :: Coef a -> Coef a +reverseCoefs (Coef n m a) = Coef m n a + +-- | Multiply a coefficient by a function of its indices, usually used +-- to change the sign of a coefficient based on its indices. +-- Does not commute with negate or reverse, usually you want to apply +-- 'alternateCoefs' first. +alternateCoefs :: RealFloat a => (Int -> Int -> a) -> Coef a -> Coef a +alternateCoefs alt (Coef n m a) = Coef n m (alt n m .*^ a) diff --git a/src/Portrait.hs b/src/Portrait.hs new file mode 100644 --- /dev/null +++ b/src/Portrait.hs @@ -0,0 +1,271 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +--------------------------------------------------------------------------------- +-- | +-- Module : Juicy +-- Copyright : (c) 2017 Jeffrey Rosenbluth +-- License : BSD-style (see LICENSE) +-- Maintainer : jeffrey.rosenbluth@gmail.com +-- +-- Tools for creating symmtery images specific to JuicyPixels. +-- +-- <> +--------------------------------------------------------------------------------- + +module Portrait + ( + -- * Wallpaper Generation + pattern + , rosette + , recipe + + -- * Color Wheels + , colorWheel + + -- * Image Processing + , invertImage + , flipVertical + , flipHorizontal + , flipBoth + , beside + , below + , antiSymmHorizontal + , antiSymmVertical + + -- * JuicyPixels Utilities + , toImageRGBA8 + , writeJpeg + , writeImage + ) where + +import Core +import Recipes.Frieze +import Recipes.Rosette +import Recipes.Wallpaper +import Types + +import Codec.Picture +import Codec.Picture.Types +import qualified Data.ByteString.Lazy as L (writeFile) +import Data.Complex +import Data.Word (Word8) +import System.FilePath (takeExtension) + +-- Domain Coloring ------------------------------------------------------------- +-- | Crate a wallpaper or phase portrait. +img2Pattern :: RealFloat a + => Options a + -> ([Coef a] -> Recipe a) + -> [Coef a] + -> WPtype a + -> PreProcess + -> FilePath + -> IO (Image PixelRGBA8) +img2Pattern opts rf cs typ pp inFile = do + dImg <- readImage inFile + return $ case dImg of + Left e -> error e + Right i -> let img' = Picture (preProcess pp . toImageRGBA8 $ i) + in case typ of + Plain -> domainColoring opts (rf cs) img' + Morph c -> morph opts (rf cs) c img' + Blend g -> blend opts (rf cs) (recipe g cs) img' + +-- | Create and write a wallpaper or frieze image. +pattern :: RealFloat a + => Options a + -> ([Coef a] -> Recipe a) + -> [Coef a] + -> WPtype a + -> PreProcess + -> Maybe FilePath + -> FilePath + -> IO () +pattern opts rf cs typ pp mInFile outFile = do + case mInFile of + Just inFile -> writeImage outFile =<< img2Pattern opts rf cs typ pp inFile + Nothing -> writeImage outFile + $ domainColoring opts (rf cs) (Function colorWheel) + +-- | Create and write a rosette. +rosette :: RealFloat a + => Options a + -> [Coef a] + -> Int + -> Bool + -> PreProcess + -> Maybe FilePath + -> FilePath + -> IO () +rosette opts cs pfold mirror pp mInFile outFile = do + case mInFile of + Just inFile -> do + dImg <- readImage inFile + let img = case dImg of + Left e -> error e + Right i -> let img' = Picture (preProcess pp . toImageRGBA8 $ i) + in if mirror + then domainColoring opts (rosettePM pfold cs) img' + else domainColoring opts (rosetteP pfold cs) img' + writeImage outFile img + Nothing -> do + let img = if mirror + then domainColoring opts (rosettePM pfold cs) (Function colorWheel) + else domainColoring opts (rosetteP pfold cs) (Function colorWheel) + writeImage outFile img + + +-- | Build a recipe for a group. +recipe :: RealFloat a => SymmetryGroup a -> [Coef a] -> Recipe a +recipe sg = case sg of + P1 a b -> p1 a b + P2 a b -> p2 a b + CM a -> cm a + CMM a -> cmm a + PM a -> pm a + PG a -> pg a + PMM a -> pmm a + PMG a -> pmg a + PGG a -> pgg a + P4 -> p4 + P4M -> p4m + P4G -> p4g + P3 -> p3 + P31M -> p31m + P3M1 -> p3m1 + P6 -> p6 + P6M -> p6m + P111 -> p111 + P211 -> p211 + P1M1 -> p1m1 + P11M -> p11m + P11G -> p11g + P2MM -> p2mm + P2MG -> p2mg + +-- | Convert a hue in radians (-pi, pi] to RGB +hue :: forall a. RealFloat a => a -> PixelRGBA8 +hue radians = case hi of + 0 -> PixelRGBA8 255 t 0 255 + 1 -> PixelRGBA8 q 255 0 255 + 2 -> PixelRGBA8 0 255 t 255 + 3 -> PixelRGBA8 0 q 255 255 + 4 -> PixelRGBA8 t 0 255 255 + 5 -> PixelRGBA8 255 0 q 255 + _ -> error "The sky is falling, mod 6 can only be [0,5]" + where + rad = if radians <= 0 then radians + 2 * pi else radians + degrees = 360 * rad / (2 * pi) + hi :: Int + hi = floor (degrees/60) `mod` 6 + t = round $ 255 * mod1 (degrees/60) + q = 255 - t + mod1 x + | f < 0 = f + 1 + | otherwise = f + where + (_, f) :: (Int, a) = properFraction x + +-- | A Color wheel on the entire complex plane. +-- The color is solely based on the phase of the complex number. +colorWheel :: RealFloat a => Complex a -> PixelRGBA8 +colorWheel z = hue (phase z) + +-- | Alter and image to use as a color wheel before making a pattern. +preProcess :: (Pixel p, Invertible p) => PreProcess -> Image p -> Image p +preProcess process = case process of + FlipHorizontal -> flipHorizontal + FlipVertical -> flipVertical + FlipBoth -> flipBoth + Invert -> invertImage + AntiSymmHorizontal -> antiSymmHorizontal + AntiSymmVertical -> antiSymmVertical + None -> id + +-- Image Processing ------------------------------------------------------------- + +-- | Invert the colors of an image. +invertImage :: (Pixel p, Invertible p) => Image p -> Image p +invertImage = pixelMap invert + +-- | Reflect and image about the horizontal axis. +flipHorizontal :: Pixel a => Image a -> Image a +flipHorizontal img@(Image w h _) = generateImage g w h + where + g x = pixelAt img (w - 1 - x) +{-# INLINEABLE flipHorizontal #-} + +-- | Reflect and image about the horizontal axis. +flipVertical :: Pixel a => Image a -> Image a +flipVertical img@(Image w h _) = generateImage g w h + where + g x y = pixelAt img x (h - 1 - y) +{-# INLINEABLE flipVertical #-} + +-- | Reflect and image about the both axis. +flipBoth :: Pixel a => Image a -> Image a +flipBoth img@(Image w h _) = generateImage g w h + where + g x y = pixelAt img (w - 1 - x) (h - 1 - y) +{-# INLINEABLE flipBoth #-} + +-- | Place two images side by side. +beside :: Pixel a => Image a -> Image a -> Image a +beside img1@(Image w1 h _) img2@(Image w2 _ _) = + generateImage g (w1 + w2) h + where + g x + | x < w1 = pixelAt img1 x + | otherwise = pixelAt img2 (x - w1) +{-# INLINEABLE beside #-} + +-- | Place the second image below the first. +below :: Pixel a => Image a -> Image a -> Image a +below img1@(Image w h1 _) img2@(Image _ h2 _) = + generateImage g w (h1 + h2) + where + g x y + | y < h1 = pixelAt img1 x y + | otherwise = pixelAt img2 x (y - h1) +{-# INLINEABLE below #-} + +-- | Flip an image horizontally, invert it and place it below the +-- original image. +antiSymmHorizontal :: (Pixel a, Invertible a) => Image a -> Image a +antiSymmHorizontal img = below img (flipHorizontal . invertImage $ img) +{-# INLINEABLE antiSymmHorizontal #-} + +-- | Flip an image vertically, invert it and place it beside the +-- original image. +antiSymmVertical :: (Pixel a, Invertible a) => Image a -> Image a +antiSymmVertical img = beside img (flipVertical . invertImage $ img) +{-# INLINEABLE antiSymmVertical #-} + +-- Utilities -------------------------------------------------------------------- + +-- | Convert a 'DynamicImage' to RGBA8 format. +toImageRGBA8 :: DynamicImage -> Image PixelRGBA8 +toImageRGBA8 (ImageRGBA8 i) = i +toImageRGBA8 (ImageRGB8 i) = promoteImage i +toImageRGBA8 (ImageYCbCr8 i) = promoteImage (convertImage i :: Image PixelRGB8) +toImageRGBA8 (ImageY8 i) = promoteImage i +toImageRGBA8 (ImageYA8 i) = promoteImage i +toImageRGBA8 (ImageCMYK8 i) = promoteImage (convertImage i :: Image PixelRGB8) +toImageRGBA8 _ = error "Unsupported Pixel type" + +-- | Write a jpeg image to a file. +writeJpeg :: Word8 -> FilePath -> Image PixelRGBA8 -> IO () +writeJpeg quality outFile img = L.writeFile outFile bs + where + bs = encodeJpegAtQuality quality (pixelMap (convertPixel . dropTransparency) img) + +-- | Write an image file to disk, the image type depends on the file extension +-- of the output file name. +writeImage :: FilePath -> Image PixelRGBA8 -> IO () +writeImage outFile img = + case takeExtension outFile of + ".png" -> writePng outFile img + ".tif" -> writeTiff outFile img + ".bmp" -> writeBitmap outFile img + ".jpg" -> writeJpeg 80 outFile img + _ -> writePng outFile img diff --git a/src/Recipes/Frieze.hs b/src/Recipes/Frieze.hs new file mode 100644 --- /dev/null +++ b/src/Recipes/Frieze.hs @@ -0,0 +1,103 @@ +--------------------------------------------------------------------------------- +-- | +-- Module : Recipes.Frieze +-- Copyright : (c) 2017 Jeffrey Rosenbluth +-- License : BSD-style (see LICENSE) +-- Maintainer : jeffrey.rosenbluth@gmail.com +-- +-- Recipes for the 17 wallpaper groups. +-- +-- For more detailed descriptions of the various symmetry groups see: +-- https://en.wikipedia.org/wiki/Frieze_group +-- and +-- "Creating Symmetry" by Frank A. Farris, 2015 Princeton University Press, +-- Chapter 8 +-- +-- The color wheel used for all of the images: +-- +-- <> +--------------------------------------------------------------------------------- + +module Recipes.Frieze + ( + -- * Frieze Groups + -- ** Frieze functions + p111 + , p211 + , p1m1 + , p11m + , p11g + , p2mm + , p2mg + + -- ** Wave functions + , nm + ) where + +import Complextra +import Core +import Types + +import Data.Complex +import Data.List (nub) + +-- Wave functions --------------------------------------------------------------- + +-- | Frieze wave function. +nm :: RealFloat a => Int -> Int -> Recipe a +nm n m z = exp (fromIntegral n .*^ (im * z)) + * exp (fromIntegral m .*^ (im * conjugate z)) + +-- Frieze Recipes --------------------------------------------------------------- + +-- | Translations only. +-- +-- <> +p111 :: RealFloat a => [Coef a] -> Recipe a +p111 = mkRecipe nm + +-- | 180 degree rotations and translations. +-- +-- <> +p211 :: RealFloat a => [Coef a] -> Recipe a +p211 cs = mkRecipe nm (nub $ cs ++ (negateCoefs <$> cs)) + +-- | Vertical reflection and translations. +-- +-- <> +p1m1 :: RealFloat a => [Coef a] -> Recipe a +p1m1 cs = mkRecipe nm (nub $ cs ++ (reverseCoefs <$> cs)) + +-- | Horizontal reflection and translations. +-- +-- <> +p11m :: RealFloat a => [Coef a] -> Recipe a +p11m cs = mkRecipe nm (nub $ cs ++ (negateCoefs . reverseCoefs <$> cs)) + +-- | Glide reflection and translations. +-- +-- <> +p11g :: RealFloat a => [Coef a] -> Recipe a +p11g cs = mkRecipe nm (nub $ cs ++ cs') + where + cs' = negateCoefs . reverseCoefs . alternateCoefs (\n m -> (-1) ^^ (n+m))<$> cs + +-- | Horizontal and vertical reflections and translations. +-- +-- <> +p2mm :: RealFloat a => [Coef a] -> Recipe a +p2mm cs = mkRecipe nm (nub $ cs ++ cs1 ++ cs2 ++ cs3) + where + cs1 = negateCoefs <$> cs + cs2 = reverseCoefs <$> cs + cs3 = negateCoefs <$> cs2 + +-- | Horizontal glide reflection and 180 rotation. +-- +-- <> +p2mg :: RealFloat a => [Coef a] -> Recipe a +p2mg cs = mkRecipe nm (nub $ cs ++ cs1 ++ cs2 ++ cs3) + where + cs1 = negateCoefs . reverseCoefs . alternateCoefs (\n m -> (-1) ^^ (n+m)) <$> cs + cs2 = negateCoefs <$> cs + cs3 = reverseCoefs . alternateCoefs (\n m -> (-1) ^^ (n+m)) <$> cs diff --git a/src/Recipes/Functions.hs b/src/Recipes/Functions.hs new file mode 100644 --- /dev/null +++ b/src/Recipes/Functions.hs @@ -0,0 +1,29 @@ + +--------------------------------------------------------------------------------- +-- | +-- Module : Recipes.Functions +-- Copyright : (c) 2017 Jeffrey Rosenbluth +-- License : BSD-style (see LICENSE) +-- Maintainer : jeffrey.rosenbluth@gmail.com +-- +-- Recipes for functions of a complex variable. +-- +-- The color wheel used for all of the images: +-- +-- <> +--------------------------------------------------------------------------------- + +module Recipes.Functions + ( + -- * Functions + identity + , standard + ) where + +import Types + +identity :: RealFloat a => Recipe a +identity = id + +standard :: RealFloat a => Recipe a +standard z = (z - 1) / (z**2 + z + 1) diff --git a/src/Recipes/Rosette.hs b/src/Recipes/Rosette.hs new file mode 100644 --- /dev/null +++ b/src/Recipes/Rosette.hs @@ -0,0 +1,54 @@ +--------------------------------------------------------------------------------- +-- | +-- Module : Recipes.Rosette +-- Copyright : (c) 2017 Jeffrey Rosenbluth +-- License : BSD-style (see LICENSE) +-- Maintainer : jeffrey.rosenbluth@gmail.com +-- +-- Recipes for Rosettes. +-- +-- For more detailed descriptions of rosettes as plane functions, seej +-- "Creating Symmetry" by Frank A. Farris, 2015 Princeton University Press, +-- Chapter 7 +-- +-- The color wheel used for all of the images: +-- +-- <> +--------------------------------------------------------------------------------- + +module Recipes.Rosette + ( + -- * Rosettes + rosetteP + , rosettePM + ) where + +import Core +import Data.Complex +import Data.List (nub) +import Types + +entire :: RealFloat a => Int -> Int -> Recipe a +entire n m z = z ^^ n * conjugate z ^^ m + +-- | Rosette recipe with p-fold symmetry. +-- /Note rosette recipe constuctors differ from those of wallpaper/ +-- /and friezes in that they filter out coefficient coordinates that/ +-- /do not satisfy n - m mod p = 0./ +-- +-- <> +rosetteP :: RealFloat a => Int -> [Coef a] -> Recipe a +rosetteP p cs = mkRecipe entire cs' + where + cs' = filter (\(Coef n m _) -> ((n-m) `mod` p) == 0) cs + +-- | Rosette recipe with p-fold and horizontal mirror symmetry. +-- /Note rosette recipe constuctors differ from those of wallpaper/ +-- /and friezes in that they filter out coefficient coordinates that/ +-- /do not satisfy n - m mod p = 0./ +-- +-- <> +rosettePM :: RealFloat a => Int -> [Coef a] -> Recipe a +rosettePM p cs = mkRecipe entire (nub $ cs' ++ (reverseCoefs <$> cs')) + where + cs' = filter (\(Coef n m _) -> ((n-m) `mod` p) == 0) cs diff --git a/src/Recipes/Wallpaper.hs b/src/Recipes/Wallpaper.hs new file mode 100644 --- /dev/null +++ b/src/Recipes/Wallpaper.hs @@ -0,0 +1,254 @@ +--------------------------------------------------------------------------------- +-- | +-- Module : Recipes.Wallpaper +-- Copyright : (c) 2017 Jeffrey Rosenbluth +-- License : BSD-style (see LICENSE) +-- Maintainer : jeffrey.rosenbluth@gmail.com +-- +-- Recipes for the 17 wallpaper groups. +-- +-- For more detailed descriptions of the various symmetry groups see: +-- https://en.wikipedia.org/wiki/Wallpaper_group +-- and +-- "Creating Symmetry" by Frank A. Farris, 2015 Princeton University Press, +-- Appendices A and B +-- +-- The color wheel used for all of the images: +-- +-- <> +-- +-- placed side by side with it's negative, that's where the purples come from. +--------------------------------------------------------------------------------- + +module Recipes.Wallpaper + ( + -- * Wallpaper Groups + + -- ** Generic Lattice + -- | Lattice vectors: __1, xi + i * eta__. + genericLattice + , p1 + , p2 + + -- ** Rhombic (Centered) Lattice + -- | Lattice vectors: __1//2 + i * b, 1//2 - i * b__. + , rhombicLattice + , cm + , cmm + + -- ** Rectangular Lattice + -- | Lattice vectors: __1, i * l__. + , rectangularLattice + , pm + , pg + , pmm + , pmg + , pgg + + -- ** Square Lattice + -- | Lattice vectors: __1, i__. + , squareLattice + , p4 + , p4m + , p4g + + -- ** Hexagonal Lattice + -- | Lattice vectors: __1, (-1 + i * sqrt(3)) // 2__. + , hexagonalLattice + , p3 + , p31m + , p3m1 + , p6 + , p6m + + -- ** Wave Functions + , enm + , tnm + , wnm + ) where + +import Complextra +import Core +import Types + +import Data.Complex +import Data.List (nub) + +-- Wave functions -------------------------------------------------------------- + +-- | Periodic waves with respect to two translations. A Fourier vector. +enm :: RealFloat a => Int -> Int -> a -> a -> Complex a +enm n m x y = exp (2 * pi * (fromIntegral n * x + fromIntegral m * y) .*^ im) + +-- | Wave packets to create 2-fold rotational symmetry. +tnm :: RealFloat a => Int -> Int -> a -> a -> Complex a +tnm n m x y = 0.5 * (enm n m x y + enm (-n) (-m) x y) + +-- | Wave packets to create 3-fold rotational symmetry. +wnm :: RealFloat a => Int -> Int -> a -> a -> Complex a +wnm n m x y = (1/3) * (enm n m x y + enm m (-n - m) x y + enm (-n - m) n x y) + +-- Recipes for the Generic Lattice --------------------------------------------- +genericLattice :: RealFloat a => a -> a -> Int -> Int -> Recipe a +genericLattice xi eta n m (x :+ y) = enm n m x' y' + where + x' = x - xi * y / eta + y' = y / eta + +-- | The symmetry group with translations only. +-- +-- <> +p1 :: RealFloat a => a -> a -> [Coef a] -> Recipe a +p1 xi eta = mkRecipe (genericLattice xi eta) + +-- | The symmetry group with four rotational centers of order 2, 180 degree +-- rotational symmetry. +-- +-- <> +p2 :: RealFloat a => a -> a -> [Coef a] -> Recipe a +p2 xi eta cs = mkRecipe (genericLattice xi eta) (nub $cs ++ (negateCoefs <$> cs)) + +-- Rhombic Lattice ------------------------------------------------------------- + +-- | Rhombic Lattice for creating symmmetry about the center. +rhombicLattice :: RealFloat a => a -> Int -> Int -> Recipe a +rhombicLattice b n m (x :+ y) = enm n m x' y' + where + x' = x + y / (2*b) + y' = x - y / (2*b) + +-- | Reflection about the horizontal axis plus horizontal glide reflection. +-- +-- <> +cm :: RealFloat a => a -> [Coef a] -> Recipe a +cm b cs = mkRecipe (rhombicLattice b) (nub $ cs ++ (reverseCoefs <$> cs)) + +-- | Rotaion and Reflection about the horizontal axis in addition to translation +-- invariance about the center of the lattice. +-- +-- <> +cmm :: RealFloat a => a -> [Coef a] -> Recipe a +cmm b cs = mkRecipe (rhombicLattice b) (nub $ cs ++ cs1 ++ cs2 ++ cs3) + where + cs1 = negateCoefs <$> cs + cs2 = reverseCoefs <$> cs + cs3 = reverseCoefs . negateCoefs <$> cs + +-- Rectangular Lattice --------------------------------------------------------- + +-- | Rectangular Lattice for creating symmetry with no rotational symmetry. +rectangularLattice :: RealFloat a => a -> Int -> Int -> Recipe a +rectangularLattice l n m (x :+ y) = enm n m x (y / l) + +-- | Rectangular Lattice for creating symmetry with 2-fold rotational symmetry. +rectangularLattice2 :: RealFloat a => a -> Int -> Int -> Recipe a +rectangularLattice2 l n m (x :+ y) = tnm n m x (y / l) + +-- | Reflection about the horizontal axis. +-- +-- <> +pm :: RealFloat a => a -> [Coef a] -> Recipe a +pm l cs = mkRecipe (rectangularLattice l) (nub $ cs ++ (negateSnd <$> cs)) + +-- | Glide reflection in the horizontal direction. +-- +-- <> +pg :: RealFloat a => a -> [Coef a] -> Recipe a +pg l cs = mkRecipe (rectangularLattice l) (nub $ cs ++ cs') + where + cs' = negateSnd . alternateCoefs (\n _ -> (-1) ^^ n) <$> cs + +-- | Reflection about the horizontal and vertical axis +-- in addition to 2-fold symmetry. +-- +-- <> +pmm :: RealFloat a => a -> [Coef a] -> Recipe a +pmm l cs = mkRecipe (rectangularLattice2 l) (nub $ cs ++ (negateSnd <$> cs)) + +-- | Glide Reflection about the horizontal axis in addition to 2-fold symmetry. +-- +-- <> +pmg :: RealFloat a => a -> [Coef a] -> Recipe a +pmg l cs = mkRecipe (rectangularLattice2 l) (nub $ cs ++ cs') + where + cs' = negateSnd . alternateCoefs (\n _ -> (-1) ^^ n) <$> cs + +-- | Glide Reflection about the line x=1/4 in addition to 2-fold symmetry. +-- +-- <> +pgg :: RealFloat a => a -> [Coef a] -> Recipe a +pgg l cs = mkRecipe (rectangularLattice2 l) (nub $ cs ++ cs') + where + cs' = negateSnd . alternateCoefs (\n m -> (-1) ^^ (n+m)) <$> cs + +-- Square Latticd--------------------------------------------------------------- + +-- | Square Lattice for creating 4-fold symmetry. +squareLattice :: RealFloat a => Int -> Int -> Recipe a +squareLattice n m (x :+ y) = 0.5 * (tnm n m x y + tnm (-n) m x y) + +-- | 4-fold symmetry only. +-- +-- <> +p4 :: RealFloat a => [Coef a] -> Recipe a +p4 = mkRecipe squareLattice + +-- | Reflection along the diagonal of the square in addition to 4-fold symmetry. +-- +-- <> +p4m :: RealFloat a => [Coef a] -> Recipe a +p4m cs = mkRecipe squareLattice (nub $ cs ++ (reverseCoefs <$> cs)) + +-- | Glide symmetry about the diagonal of the sqaure in addition to +-- 4-fold symmetry. +-- +-- <> +p4g :: RealFloat a => [Coef a] -> Recipe a +p4g cs = mkRecipe squareLattice (nub $ cs ++ cs') + where + cs' = reverseCoefs . alternateCoefs (\n m -> (-1) ^^ (n+m)) <$> cs + +-- Hexagonal Lattice ----------------------------------------------------------- + +-- | Hexagonal Lattice for creating 3-fold symmetry. +hexagonalLattice :: RealFloat a => Int -> Int -> Recipe a +hexagonalLattice n m (x :+ y) = (1/3) * (enm n m x' y' + enm m (-n - m) x' y' + enm (-n - m) n x' y') + where + x' = x + y / sqrt3 + y' = 2 * y / sqrt3 + sqrt3 = sqrt 3 + +-- | 3-fold symmetry only. +-- +-- <> +p3 :: RealFloat a => [Coef a] -> Recipe a +p3 = mkRecipe hexagonalLattice + +-- | Reflection about the horizontal axis in addition to 3-fold symmetry. +-- +-- <> +p31m :: RealFloat a => [Coef a] -> Recipe a +p31m cs = mkRecipe hexagonalLattice (nub $ cs ++ (reverseCoefs <$> cs)) + +-- | Reflction about the vertical axis in addtion to 3-fold symmetry. +-- +-- <> +p3m1 :: RealFloat a => [Coef a] -> Recipe a +p3m1 cs = mkRecipe hexagonalLattice (nub $ cs ++ (negateCoefs . reverseCoefs <$> cs)) + +-- | 60 degree Rotation in addtion to 3-fold symmetry. +-- +-- <> +p6 :: RealFloat a => [Coef a] -> Recipe a +p6 cs = mkRecipe hexagonalLattice (nub $ cs ++ (negateCoefs <$> cs)) + +-- | 60 degree Rotation and reflection about the horizontal in addtion +-- to 3-fold symmetry. +-- +-- <> +p6m :: RealFloat a => [Coef a] -> Recipe a +p6m cs = mkRecipe hexagonalLattice (nub $ cs ++ cs1 ++ cs2 ++ cs3) + where + cs1 = negateCoefs <$> cs + cs2 = reverseCoefs <$> cs + cs3 = negateCoefs <$> cs2 diff --git a/src/Types.hs b/src/Types.hs new file mode 100644 --- /dev/null +++ b/src/Types.hs @@ -0,0 +1,312 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TypeSynonymInstances #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Types +-- Copyright : (c) 2017 Jeffrey Rosenbluth +-- License : BSD-style (see LICENSE) +-- Maintainer : jeffrey.rosenbluth@gmail.com +-- +-- Types and classes for creating symmtery images using the domain coloring +-- algortihm. +-- +-- <> +-------------------------------------------------------------------------------- + +module Types + ( ColorSource(..) + , Coef(..) + , Options(..) + , defaultOpts + , SymmetryGroup(..) + , PreProcess(..) + , WPtype(..) + , Wallpaper(..) + , Rosette(..) + , Function(..) + , Recipe + , Invertible(..) + , BlackWhite(..) + ) where + +import Codec.Picture +import Data.Complex +import Data.Text (Text, toLower) +import Data.Yaml + +-- | A 'Recipe' is a mapping from the complex plange to the complex plane. +type Recipe a = Complex a -> Complex a + +-- | A color source can be either a JuicyPixels image or a function from +-- a complex number to a pixel. +data ColorSource a p + = Picture (Image p) + | Function (Complex a -> p) + +-- | The coefficents used to build a symmetry recipe, C_nm. A coeffient +-- is a doubley indexed complex number +data Coef a = Coef + { nCoord :: Int -- ^ The first index. + , mCoord :: Int -- ^ The second index. + , anm :: Complex a -- ^ The coefficient. + } deriving (Show, Eq, Functor) + +instance FromJSON a => FromJSON (Complex a) where + parseJSON a@(Array _) = do + (r, i) <- parseJSON a + return $ r :+ i + parseJSON _ = fail "Expected Array for a Complex value." + +instance FromJSON a => FromJSON (Coef a) where + parseJSON (Object v) + = Coef + <$> v .: "n" + <*> v .: "m" + <*> v .: "A(n,m)" + parseJSON _ = fail "Expected Object for Coef value." + +-- | Settings for the size, repeat lenght, and scaling factor for creating a +-- a domain coloring. +data Options a = Options + { width :: Int -- ^ The width of the created image. + , height :: Int -- ^ The height of the created iamge. + , repLength :: Int -- ^ The length of the pattern to repeat. + , scale :: a -- ^ Usually set less than 1, to compensate for the + -- fact that the color wheel is not infinite. + } deriving (Show, Eq, Functor) + +instance FromJSON a => FromJSON (Options a) where + parseJSON (Object v) + = Options + <$> v .: "width" + <*> v .: "height" + <*> v .: "repeat-length" + <*> v .: "scale-factor" + parseJSON _ = fail "Expected Object for a Options value." + +-- | The defaul 'Options' creates a square 750 x 750 pixel image, +-- with a repeat of 150 pixels and scales the pixel lookup coordintes +-- by 1/2. +defaultOpts :: Options Double +defaultOpts = Options 750 750 150 0.5 + +-- | The 17 Wallpaper groups and 7 Frieze groups. +data SymmetryGroup a + = P1 a a -- ^ Arguments are ξ and η. + -- The lattice vectors are 1 and ξ + /i/ η. + | P2 a a -- ^ Arguments are ξ and η. + -- The lattice vectors are 1 and ξ + /i/ η. + | CM a -- ^ The argument is /b/ with lattice vectors 1//2 +- ib/. + | CMM a -- ^ The argument is /b/ with lattice vectors 1//2 +- ib/. + | PM a -- ^ The argument is /L/ with lattice vectors 1 and /iL/. + | PG a -- ^ The argument is /L/ with lattice vectors 1 and /iL/. + | PMM a -- ^ The argument is /L/ with lattice vectors 1 and /iL/. + | PMG a -- ^ The argument is /L/ with lattice vectors 1 and /iL/. + | PGG a -- ^ The argument is /L/ with lattice vectors 1 and /iL/. + | P4 + | P4M + | P4G + | P3 + | P31M + | P3M1 + | P6 + | P6M + | P111 + | P211 + | P1M1 + | P11M + | P11G + | P2MM + | P2MG + deriving (Show, Eq, Functor) + +instance FromJSON a => FromJSON (SymmetryGroup a) where + parseJSON (Object v) = do + (name :: Text) <- v .: "name" + case toLower name of + "p1" -> P1 <$> v .: "xi" <*> v .: "eta" + "p2" -> P2 <$> v .: "xi" <*> v .: "eta" + "cm" -> CM <$> v .: "b" + "cmm" -> CMM <$> v .: "b" + "pm" -> PM <$> v .: "L" + "pg" -> PG <$> v .: "L" + "pmm" -> PMM <$> v .: "L" + "pmg" -> PMG <$> v .: "L" + "pgg" -> PGG <$> v .: "L" + s -> parseGroup s + parseJSON (String s) = parseGroup s + parseJSON _ = fail "Group must be an object or String" + +parseGroup :: Monad m => Text -> m (SymmetryGroup a) +parseGroup s = case toLower s of + "p4" -> pure P4 + "p4m" -> pure P4M + "p4g" -> pure P4G + "p3" -> pure P3 + "p31m" -> pure P31M + "p3m1" -> pure P3M1 + "p6" -> pure P6 + "p6m" -> pure P6M + "p111" -> pure P111 + "p211" -> pure P211 + "p1m1" -> pure P1M1 + "p11m" -> pure P11M + "p11g" -> pure P11G + "p2mm" -> pure P2MM + "p2mg" -> pure P2MG + _ -> fail "Tried to parse an invalid group name." + +-- | The type of wallpaper to produce. +data WPtype a + = Plain + | Morph a + | Blend (SymmetryGroup a) + deriving (Show, Eq, Functor) + +instance FromJSON a => FromJSON (WPtype a) where + parseJSON (Object v) = do + (typ :: String) <- v .: "style" + case typ of + "plain" -> pure Plain + "morph" -> Morph <$> v .: "cutoff" + "blend" -> Blend <$> v .: "group" + _ -> fail "Tried to parse an invalide wallpaper type." + parseJSON _ = fail "Expected a String for the wallpaper type." + +-- | What to do the color wheel before creating the Wallpaper. +data PreProcess + = FlipHorizontal + | FlipVertical + | FlipBoth + | Invert + | AntiSymmHorizontal + | AntiSymmVertical + | None + deriving (Show, Eq) + +instance FromJSON PreProcess where + parseJSON (String s) = + case toLower s of + "fliphorizontal" -> pure FlipHorizontal + "flipvertical" -> pure FlipVertical + "flipboth" -> pure FlipBoth + "invert" -> pure Invert + "antisymmvertical" -> pure AntiSymmVertical + "antisymmhorizontal" -> pure AntiSymmHorizontal + "none" -> pure None + _ -> fail "Invalid Pre-process type" + parseJSON _ = fail "Pre-process must be a String" + +-- | Settings for creating a wallpaper. +data Wallpaper a = Wallpaper + { wpGroup :: SymmetryGroup a + , wpCoefs :: [Coef a] + , wpType :: WPtype a + , wpOptions :: Options a + , wpWheel :: Maybe FilePath + , wpProcess :: PreProcess + , wpPath :: FilePath + } deriving (Show, Eq, Functor) + +instance FromJSON a => FromJSON (Wallpaper a) where + parseJSON (Object v) + = Wallpaper + <$> v .: "Group" + <*> v .: "Coefficients" + <*> v .:? "Type" .!= Plain + <*> v .: "Options" + <*> v .:? "Colorwheel-path" .!= Nothing + <*> v .:? "Pre-process" .!= None + <*> v .: "Output-path" + parseJSON _ = fail "Expected Object for Wallpaper value." + +-- | Settings for creating a rosette. +data Rosette a = Rosette + { rsFoldSym :: Int + , rsMirror :: Bool + , rsCoefs :: [Coef a] + , rsOptions :: Options a + , rsWheel :: Maybe FilePath + , rsProcess :: PreProcess + , rsPath :: FilePath + } deriving (Show, Eq, Functor) + +instance FromJSON a => FromJSON (Rosette a) where + parseJSON (Object v) + = Rosette + <$> v .: "P-fold" + <*> v .: "Mirror" + <*> v .: "Coefficients" + <*> v .: "Options" + <*> v .:? "Colorwheel-path" .!= Nothing + <*> v .:? "Pre-process" .!= None + <*> v .: "Output-path" + parseJSON _ = fail "Expected Object for Rosette value." + +-- | Settings for creating a phase portrait. +data Function a = Fn + { fnOptions :: Options a + , fnWeel :: FilePath + , fnProcess :: PreProcess + , fnPath :: FilePath + } deriving (Show, Eq, Functor) + + +-------------------------------------------------------------------------------- +-- | Pixels that can be set to black and white. +class BlackWhite a where + black :: a + white :: a + +instance BlackWhite PixelRGBA8 where + black = PixelRGBA8 0 0 0 255 + white = PixelRGBA8 255 255 255 255 + +instance BlackWhite PixelRGB8 where + black = PixelRGB8 0 0 0 + white = PixelRGB8 255 255 255 + +instance BlackWhite PixelYCbCr8 where + black = PixelYCbCr8 0 0 0 + white = PixelYCbCr8 255 255 255 + +instance BlackWhite Pixel8 where + black = 0 + white = 255 + +instance BlackWhite PixelYA8 where + black = PixelYA8 0 255 + white = PixelYA8 255 255 + +instance BlackWhite PixelCMYK8 where + black = PixelCMYK8 0 0 0 255 + white = PixelCMYK8 0 0 0 0 + +-------------------------------------------------------------------------------- +-- | Invert the color of a pixel. +class Invertible a where + invert :: a -> a + +instance Invertible PixelRGBA8 where + invert (PixelRGBA8 r g b a) = PixelRGBA8 (255-r) (255-g) (255-b) a + +instance Invertible PixelRGB8 where + invert (PixelRGB8 r g b) = PixelRGB8 (255-r) (255-g) (255-b) + +instance Invertible PixelYCbCr8 where + invert (PixelYCbCr8 r g b) = PixelYCbCr8 (255-r) (255-g) (255-b) + +instance Invertible Pixel8 where + invert p = 255 - p + +instance Invertible PixelYA8 where + invert (PixelYA8 c a) = PixelYA8 (255-c) a + +instance Invertible PixelCMYK8 where + invert (PixelCMYK8 r g b a) = PixelCMYK8 (255-r) (255-g) (255-b) a diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +main :: IO () +main = putStrLn "Test suite not yet implemented" diff --git a/wallpaper.cabal b/wallpaper.cabal new file mode 100644 --- /dev/null +++ b/wallpaper.cabal @@ -0,0 +1,94 @@ +name: wallpaper +version: 0.1.0.0 +synopsis: A library and executable for creating + wallpaper, frieze, and rosette patterns. + +description: @wallpaper@ provides the tools needed to make your own + wallpapers, friezes and rosettes as described in Frank A. + Farris's beuatiful book + . + Following Farris we use the + + algorithm to create recipes that convert an arbitrary image + to a pattern. For example, using the this image + . + <> + . + We can make + . + <> + . + For maximum flexibily the @wallpaper@ library provides an + EDSL for their creation, + alternatively the @wallpaper@ and @rosette@ executables + can be used with a yaml file to create a large variety of + patterns. + +homepage: https://github.com/githubuser/wallpaper#readme +license: BSD3 +license-file: LICENSE +author: Jeffrey Rosenbluth +maintainer: jeffrey.rosenbluth@gmail.com +copyright: Copyright (c) 2017 Jeffrey Rosenbluth +category: Graphics +build-type: Simple +stability: Beta +extra-source-files: README.md +extra-doc-files: examples/*.png +cabal-version: >=1.10 + +source-repository head + type: git + location: https://github.com/jeffreyrosenbluth/wallpaper + +library + hs-source-dirs: src + ghc-options: -Wall -O2 + exposed-modules: Core + , Complextra + , Portrait + , Recipes.Wallpaper + , Recipes.Frieze + , Recipes.Rosette + , Recipes.Functions + , Types + build-depends: base >= 4.7 && < 5 + , JuicyPixels >= 3.2 && < 3.3 + , bytestring >= 0.10 && < 0.11 + , filepath >= 1.4 && < 1.5 + , yaml >= 0.8 && < 0.9 + , text >= 1.2 && < 1.3 + default-language: Haskell2010 + +executable wallpaper + hs-source-dirs: app + main-is: Wallpaper.hs + ghc-options: -threaded -rtsopts -with-rtsopts=-N -O2 + build-depends: base + , wallpaper + , JuicyPixels >= 3.2 && < 3.3 + , yaml >= 0.8 && < 0.9 + default-language: Haskell2010 + +executable rosette + hs-source-dirs: app + main-is: Rosette.hs + ghc-options: -threaded -rtsopts -with-rtsopts=-N -O2 + build-depends: base + , wallpaper + , JuicyPixels >= 3.2 && < 3.3 + , yaml >= 0.8 && < 0.9 + default-language: Haskell2010 + +test-suite wallpaper-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + build-depends: base + , wallpaper + ghc-options: -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/jeffreyrosenbluth/wallpaper