diff --git a/IFS.cabal b/IFS.cabal new file mode 100644 --- /dev/null +++ b/IFS.cabal @@ -0,0 +1,24 @@ +Name: IFS +Version: 0.1 +License: BSD3 +License-file: LICENSE +Author: alpheccar +Copyright: Copyright (c) 2007, alpha +category: Graphics +synopsis: Iterated Function System generation for Haskell +description: Library to describe IFS and generate PPM pictures from the descriptions +maintainer: misc@NOSPAMalpheccar.org +homepage: http://www.alpheccar.org +hs-source-dirs: src/ +ghc-options: -O -fglasgow-exts +exposed-Modules: + Graphics.IFS, + Graphics.IFS.Examples, + Graphics.IFS.Geometry, + Graphics.IFS.Ppm +build-depends: base>=2.0, haskell98, mtl + +Executable: IFS +hs-source-dirs: src/ +Main-is: main.hs +ghc-options: -O -fglasgow-exts diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,24 @@ +* Copyright (c) 2007, alpheccar +* 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 alpheccar.org nor the +* names of its contributors may be used to endorse or promote products +* derived from this software without specific prior written permission. +* +* THIS SOFTWARE IS PROVIDED BY THE REGENTS 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 REGENTS AND 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/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +module Main where +import Distribution.Simple( defaultMain ) +main = defaultMain diff --git a/src/Graphics/IFS.hs b/src/Graphics/IFS.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/IFS.hs @@ -0,0 +1,101 @@ +--------------------------------------------------------------------------- +-- | +-- Module : Main +-- Copyright : (c) alpheccar, 2007 +-- License : BSD-style +-- +-- Maintainer : misc@alpheccar.org +-- Stability : experimental +-- Portability : portable +-- +-- Description +-- +-- Iterated Function Systems in Haskell +-- +----------------------------------------------------------------------------- + +module Graphics.IFS ( + -- * Types + IFS + , Pixel + -- * Drawing an IFS + , drawIFS + -- * IFS creation functions + , (<+>) + , () + , linearIFS + ) + where + +import Graphics.IFS.Geometry +import Control.Monad(liftM2,liftM) +import System.Random +import Data.Word + +-- | A position in an array of pixels and the color index +type Pixel = (Int,Word8) + +-- | An IFS is expressed in a [0,1]x[0,1] squares. So, the linear transforms used to build it must take that into account. +newtype IFS a = IFS([(NonLinearTransform a,Double)]) + +infixl 5 <+> +infixl 6 + +-- | Union of two IFS (probabilities are normalized if required when the IFS is drawn) +(<+>) :: IFS a -> IFS a -> IFS a +(IFS la) <+> (IFS lb) = IFS (la ++ lb) + +-- | Multiply IFS probabilities +() :: Double -> IFS a -> IFS a +p (IFS la) = IFS $ map changeProba la where + changeProba (nl,op) = (nl,p*op) + +-- | Create a linear IFS from an affine transformation +linearIFS :: M a -> IFS a +linearIFS m = IFS [(NL(id,m),1.0)] + +-- | The sum of all probabilities must be 1 +normalizeProba :: IFS a -> IFS a +normalizeProba (IFS l) = IFS $ map (divideBy total) l + where + total = sum . map snd $ l + divideBy x (a,p) = (a,p/x) + +-- | For applying a non linear transformation to the IFS +instance Num a => Module (NonLinear a) (IFS a) where + f <*> (IFS l) = IFS (map applyTransform l) where + applyTransform (n,p) = (f <*> n,p) + +-- | For applying a linear transformation to an IFS +instance Fractional a => Module (M a) (IFS a) where + f <*> (IFS l) = IFS $ map applyTransform l where + applyTransform (NL(n,m),p) = (NL(n,f * m * (inv f)),p) + +-- | For applying a scalar transformation to an IFS +instance Num a => Module a (IFS a) where + f <*> (IFS l) = IFS $ map applyTransform l where + applyTransform (NL(n,m),p) = (NL(n,f <*> m),p) + +-- | Pick a non linear transformation from the IFS according to the given proba +pick :: IFS a -> Double -> NonLinearTransform a +pick (IFS l) = getTransform l + where + getTransform ((a,_):[]) _ = a + getTransform ((x,p):ps) n | n <= p = x + | otherwise = getTransform ps (n-p) + +-- | Draw an IFS +drawIFS :: Int -- ^ Width of the IFS square in pixel (the IFS is contained in a [0,1]x[0,1] square) + -> Int -- ^ Height of the IFS square + -> Int -- ^ Number of pixels to generate + -> IFS Double -- ^ The IFS + -> [Pixel] -- ^ List of pixels +drawIFS width height n x = genPixel . take n . drop 100 . scanl (flip (<*>)) startVector . map (pick (normalizeProba x)) . randomRs ((0.0,1.0)::(Double,Double)) $ mkStdGen 0 + where + genPixel [] = [] + genPixel (V(x,y):l) = + let ny = 1 - y + minb = 0 + maxb = width*height + p = floor ((fromIntegral width)*x) + width*floor ((fromIntegral height)*ny) in + if (x>=0) && (ny>=0) && (x<1.0) && (ny<1.0) && (p >= minb) && (p < maxb) then (p,1):genPixel l else genPixel l diff --git a/src/Graphics/IFS/Examples.hs b/src/Graphics/IFS/Examples.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/IFS/Examples.hs @@ -0,0 +1,72 @@ +--------------------------------------------------------------------------- +-- | +-- Module : Main +-- Copyright : (c) alpheccar, 2007 +-- License : BSD-style +-- +-- Maintainer : misc@alpheccar.org +-- Stability : experimental +-- Portability : non-portable (multi-parameter type classes) +-- +-- Description +-- +-- Example IFS +-- +----------------------------------------------------------------------------- + +module Graphics.IFS.Examples( + -- * Example IFS + sierpinski + , square + , fern + -- * Example of use + -- $Example + ) + where + +import Graphics.IFS.Geometry +import Graphics.IFS + +sierpinski :: IFS Double +sierpinski = 0.33 linearIFS (scaling 0.5 0.5) + <+> 0.33 linearIFS (translation 0.5 0 * scaling 0.5 0.5) + <+> 0.33 linearIFS (translation 0 0.5 * scaling 0.5 0.5) + +square :: IFS Double +square = 0.25 linearIFS (scaling 0.5 0.5) + <+> 0.25 linearIFS (translation 0.5 0 * scaling 0.5 0.5) + <+> 0.25 linearIFS (translation 0 0.5 * scaling 0.5 0.5) + <+> 0.25 linearIFS (translation 0.5 0.5 * scaling 0.5 0.5) + +fern :: IFS Double +fern = (0.01 linearIFS(linear 0 0 0 0.16 0 0) + <+> 0.08 linearIFS(linear 0.2 (-0.26) 0.23 0.22 0 1.6) + <+> 0.08 linearIFS(linear (-0.15) 0.28 0.26 0.24 0 0.44) + <+> 0.74 linearIFS(linear 0.75 0.04 (-0.04) 0.85 0 1.6)) + +{- $Example + +[Generating the fractal for the Sierpinski IFS:] + +> createPict "essai.ppm" 600 600 1.0 200000 (binaryColor white blue) sierpinski + +[Combining square and sierpinski:] + +> createPict "essai.ppm" 600 600 1.0 200000 (binaryColor white blue) (0.5 square <+> 0.5 sierpinski) + +[Definitions of the examples:] + +> sierpinski :: IFS Double +> sierpinski = 0.33 linearIFS (scaling 0.5 0.5) +> <+> 0.33 linearIFS (translation 0.5 0 * scaling 0.5 0.5) +> <+> 0.33 linearIFS (translation 0 0.5 * scaling 0.5 0.5) +> + +> square :: IFS Double +> square = 0.25 linearIFS (scaling 0.5 0.5) +> <+> 0.25 linearIFS (translation 0.5 0 * scaling 0.5 0.5) +> <+> 0.25 linearIFS (translation 0 0.5 * scaling 0.5 0.5) +> <+> 0.25 linearIFS (translation 0.5 0.5 * scaling 0.5 0.5) + + +-} diff --git a/src/Graphics/IFS/Geometry.hs b/src/Graphics/IFS/Geometry.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/IFS/Geometry.hs @@ -0,0 +1,222 @@ +--------------------------------------------------------------------------- +-- | +-- Module : Main +-- Copyright : (c) alpheccar, 2007 +-- License : BSD-style +-- +-- Maintainer : misc@alpheccar.org +-- Stability : experimental +-- Portability : non-portable (multi-parameter type classes) +-- +-- Description +-- +-- Some geometry operations used by the IFS +-- +----------------------------------------------------------------------------- + +module Graphics.IFS.Geometry ( + -- * Types + -- ** Matrix and Vector + M + , V(..) + -- ** Non linear transformations + , NonLinear + , NonLinearTransform(..) + -- ** Modules + , Module(..) + -- * Creating linear transformations + , linear + , rotation + , scaling + , translation + -- * Non linear transformations + , v0 + , v1 + , v2 + , v3 + , v4 + , v5 + , v6 + , v7 + , v8 + , v9 + , v10 + , v11 + , v12 + -- * Misc + , startVector + , inv + , det + ) + where + +-- | Affine transform on 2x2 space +newtype M a = M(a,a,a,a,a,a) deriving(Eq,Show) + +-- | Vector +newtype V a = V(a,a) deriving(Eq,Show) + +-- | A pure non linear transformation +type NonLinear a = V a -> V a + +-- | A non linear transformation with a pure non linear part and an affine one +newtype NonLinearTransform a = NL (NonLinear a,M a) + +-- | Start vector used to initiate the generation of a random trajectory +startVector :: V Double +startVector = V(0.5,0.5) + +instance Num a => Num (M a) where + (+) (M (a,b,c,d,e,f)) (M (a',b',c',d',e',f')) = M (a+a',b+b',c+c',d+d',e+e',f+f') + (-) (M (a,b,c,d,e,f)) (M (a',b',c',d',e',f')) = M (a-a',b-b',c-c',d-d',e-e',f-f') + (*) (M (a,b,c,d,e,f)) (M (a',b',c',d',e',f')) = M (a*a' + b*c',a*b' + b*d',c*a' + d*c',c*b' + d*d',a*e' + b*f' + e,c*e' + d*f' + f) + abs (M (a,b,c,d,e,f)) = M (abs a,abs b,abs c,abs d,abs e,abs f) -- Just because I need to define it :-( + signum (M (a,b,c,d,e,f)) = M (signum a,signum b,signum c,signum d,signum e,signum f) -- Just because I need to define it :-( + fromInteger a = M (fromInteger a,0,0,fromInteger a,0,0) + +instance Num a => Num (V a) where + (+) (V (a,b)) (V (a',b')) = V (a+a',b+b') + (-) (V (a,b)) (V (a',b')) = V (a-a',b-b') + (*) (V (a,b)) (V (a',b')) = V (a*a',b*b') + abs (V (a,b)) = V (abs a,abs b) -- Just because I need to define it :-( + signum (V (a,b)) = V (signum a,signum b) -- Just because I need to define it :-( + fromInteger a = V (fromInteger a,0 )-- arbitrary + +infixr 5 <*> + +-- | Elements which can be transformed by an operator +class Module a b where + (<*>) :: a -> b -> b + +instance Num a => Module a (V a) where + (<*>) a (V (x,y)) = V (a*x,a*y) + +instance Num a => Module a (M a) where + (<*>) x (M (a,b,c,d,e,f)) = M (x*a,b,c,x*d,x*e,x*f) + +instance Num a => Module (M a) (V a) where + (<*>) (M (a,b,c,d,e,f)) (V (x,y)) = V (a*x+b*y + e,c*x+d*y + f) + +instance Num a => Module (NonLinearTransform a) (V a) where + (<*>) (NL(f,m)) v = f (m <*> v) + +instance Num a => Module (NonLinear a) (NonLinearTransform a) where + f <*> (NL(g,m)) = NL (f.g,m) + + +det :: (Num a) => M a -> a +det (M (a,b,c,d,_,_)) = a*d - b*c + +inv :: (Fractional a) => M a -> M a +inv m@(M (a,b,c,d,e,f)) = M(d/de,-b/de,-c/de,a/de,0,0) * M(1,0,0,1,-e,-f) + where + de = det m + +-- | Create a pure affine transformation +-- Linear part: +-- a b +-- c d +-- Affine part: +-- e +-- f +linear :: Num a => a -- ^ a + -> a -- ^ b + -> a -- ^ c + -> a -- ^ d + -> a -- ^ e + -> a -- ^ f + -> M a +linear a b c d e f =M(a,b,c,d,e,f) + +-- | Linear +v0 ::NonLinear Double +v0 (V(x,y)) = V(x,y) + +-- | Sinusoidal +v1 :: NonLinear Double +v1 (V(x,y)) = V(sin x,sin y) + +-- | Spherical +v2 :: NonLinear Double +v2 (V(x,y)) = V(x/(r2+1e-6),y/(r2+1e-6)) + where + r2 = x*x + y*y + +-- | Swirl +v3 :: NonLinear Double +v3 (V(x,y)) = V(r*cos(theta+r),r*sin(theta+r)) + where + theta = atan(x/y) + r = sqrt(x*x + y*y) + +-- | Horseshoe +v4 :: NonLinear Double +v4 (V(x,y)) = V(r*cos(2*theta),r*sin(2*theta)) + where + theta = atan(x/y) + r = sqrt(x*x + y*y) + +-- | Polar +v5 :: NonLinear Double +v5 (V(x,y)) = V(theta/pi,r-1) + where + theta = atan(x/y) + r = sqrt(x*x + y*y) + +-- | Handkerchief +v6 :: NonLinear Double +v6 (V(x,y)) = V(r*sin(theta+r),r*cos(theta-r)) + where + theta = atan(x/y) + r = sqrt(x*x + y*y) + +-- | Heart +v7 :: NonLinear Double +v7 (V(x,y)) = V(r*sin(theta*r),-r*cos(theta*r)) + where + theta = atan(x/y) + r = sqrt(x*x + y*y) + +-- | Disc +v8 :: NonLinear Double +v8 (V(x,y)) = V(theta*sin(pi*r)/pi,theta*cos(pi*r)/pi) + where + theta = atan(x/y) + r = sqrt(x*x + y*y) + +-- | Spiral +v9 :: NonLinear Double +v9 (V(x,y)) = V(((cos theta) + (sin r))/r,((sin theta)-(cos r))/r) + where + theta = atan(x/y) + r = sqrt(x*x + y*y) + +-- | Hyperbolic +v10 :: NonLinear Double +v10 (V(x,y)) = V(sin(theta)/r,cos(theta)*r) + where + theta = atan(x/y) + r = sqrt(x*x + y*y) + +-- | Diamond +v11 :: NonLinear Double +v11 (V(x,y)) = V((sin theta)*(cos r),(cos theta)*(sin r)) + where + theta = atan(x/y) + r = x*x + y*y + +-- | Ex +v12 :: NonLinear Double +v12 (V(x,y)) = V(r*(sin(theta+r))^3,r*(cos(theta-r))^3) + where + theta = atan(x/y) + r = sqrt(x*x + y*y) + +rotation :: Double -> M Double +rotation t = M (cos (t*pi/180),sin (t*pi/180),-sin (t*pi/180),cos (t*pi/180),0,0) + +scaling :: Double -> Double -> M Double +scaling sx sy = M(sx,0,0,sy,0,0) + +translation :: Double -> Double -> M Double +translation tx ty = M(1,0,0,1,tx,ty) diff --git a/src/Graphics/IFS/Ppm.hs b/src/Graphics/IFS/Ppm.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/IFS/Ppm.hs @@ -0,0 +1,114 @@ +--------------------------------------------------------------------------- +-- | +-- Module : Main +-- Copyright : (c) alpheccar, 2007 +-- License : BSD-style +-- +-- Maintainer : misc@alpheccar.org +-- Stability : experimental +-- Portability : portable +-- +-- Description +-- +-- Portable Pixel Map +-- +----------------------------------------------------------------------------- + +module Graphics.IFS.Ppm ( + -- * Color formats + Color(..) + -- * Picture Creation + , createPict + -- * Some standard colors + , red + , green + , blue + , white + , black + -- * Coloring functions + , ColorizeFunction + , binaryColor + , densityColor + ) + where + +import Data.Word +import Control.Monad +import Data.Array.Unboxed +import System.IO +import Control.Exception(bracket) +import qualified Data.ByteString as B +import Graphics.IFS(drawIFS,IFS) + + +-- | Image encoded as an unidimensional array and indexed colors. +-- The meaning of the index color is dependent on the choice of a coloring function +type Image = UArray Int Word8 + +-- | RGB Color +data Color = RGB Word8 Word8 Word8 deriving(Eq,Ord) + +-- | Red color +red :: Color +red = RGB 255 0 0 + +-- | Gree color +green :: Color +green = RGB 0 255 0 + +-- | Blue color +blue :: Color +blue = RGB 0 0 255 + +-- | Black color +black :: Color +black = RGB 0 0 0 + +-- | white color +white :: Color +white = RGB 255 255 255 + +withFile :: String -> (Handle -> IO a) -> IO a +withFile name = bracket (openBinaryFile name WriteMode) hClose + + +-- | The type of a coloring functions. +-- The first argument is an index value and the second argument is a list of RGB value. +-- The function is assumed to concatenate a new triple of RGB value to the list +type ColorizeFunction = Word8 -> [Word8] -> [Word8] + +-- | Binary coloring +binaryColor :: Color -- ^ Background 'Color' for index null + -> Color -- ^ Foreground 'Color' for index not null + -> Word8 -- ^ Index + -> [Word8] -- ^ List of RGB values + -> [Word8] -- ^ List of RGB values +binaryColor (RGB br bg bb) (RGB r g b) a n | a /= 0 = r:g:b:n + | otherwise = br:bg:bb:n + +-- | Density coloring with linear interpolation +densityColor :: Int -- ^ Scaling factor + -> Color -- ^ Background 'Color' for index null + -> Color -- ^ Foreground 'Color' for index not null + -> Word8 -- ^ Index + -> [Word8] -- ^ List of RGB values + -> [Word8] -- ^ List of RGB values +densityColor m (RGB br bg bb) (RGB r g b) a n | a /= 0 = (scale r):(scale g):(scale b):n + | otherwise = br:bg:bb:n + where + scale r = fromInteger $ floor $ (min ((fromIntegral a) / (fromIntegral m)) (1.0::Double)) * (fromIntegral r) + +-- | Create a PPM picture. +createPict :: String -- ^ Name of file + -> Int -- ^ Picture width + -> Int -- ^ Picture height + -> Int -- ^ Nb of pixels to compute + -> ColorizeFunction -- ^ How to colorize the result + -> IFS Double -- ^ IFS + -> IO() -- ^ Output action +createPict name width height nb colorize ifs = do + withFile name $ \h -> do + hPutStr h ("P6 " ++ show width ++ " " ++ show height ++ " 255\n") + B.hPut h $ B.pack $ foldr colorize [] $ elems $ (accumArray (+) 0 (0,width*height) $ drawIFS width height nb ifs :: Image) + + diff --git a/src/main.hs b/src/main.hs new file mode 100644 --- /dev/null +++ b/src/main.hs @@ -0,0 +1,29 @@ +--------------------------------------------------------------------------- +-- | +-- Module : Main +-- Copyright : (c) alpheccar, 2007 +-- License : BSD-style +-- +-- Maintainer : misc@alpheccar.org +-- Stability : experimental +-- Portability : portable +-- +-- Description +-- +-- Iterated Function Systems in Haskell +-- +----------------------------------------------------------------------------- + + +module Main where + +import Graphics.IFS.Ppm +import Graphics.IFS.Geometry +import Graphics.IFS.Examples +import Graphics.IFS + +main = do + putStrLn "Generating sierpinski ..." + createPict "sierpinski.ppm" 600 600 200000 (binaryColor (RGB 238 238 238) blue) sierpinski + putStrLn "Generating fern ..." + createPict "fern.ppm" 600 600 200000 (binaryColor (RGB 238 238 238) green) (translation 0.5 0 <*> scaling 0.1 0.1 <*> fern)