packages feed

IFS (empty) → 0.1

raw patch · 8 files changed

+589/−0 lines, 8 filesdep +basedep +haskell98dep +mtlbuild-type:Customsetup-changed

Dependencies added: base, haskell98, mtl

Files

+ IFS.cabal view
@@ -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
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,3 @@+module Main where+import Distribution.Simple( defaultMain )+main = defaultMain
+ src/Graphics/IFS.hs view
@@ -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
+ src/Graphics/IFS/Examples.hs view
@@ -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) +++-}
+ src/Graphics/IFS/Geometry.hs view
@@ -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)
+ src/Graphics/IFS/Ppm.hs view
@@ -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)++
+ src/main.hs view
@@ -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)