Xec-0.1.6: Identicon.hs

module Identicon where
import Control.Monad
import Data.List
import Graphics.Rendering.Cairo
import Text.Printf

curry3 f a b c=f (a,b,c)
uncurry3 f (a,b,c)=f a b c

defaultBlocks :: [Block]
defaultBlocks=nub $ concatMap expand
    [Block [0,1,4,3]
    ,Block [0,1,6]
    ,Block [0,1,3]
    ,Block [1,4,3]
    ,Block [0,1,7,6]
    ,Block [0,1,8,3]
    ,Block [0,1,5,8,7,3]
    ,Block [0,1,7,3]
    ,Block [0,1,3,7,6,3]
 --   ,Block [1,5,7,3] -- intentionally omitted for an aesthetic reason
    ]

defaultColors :: [Color]
defaultColors=map (\ix->hsvColor (fromIntegral ix/fromIntegral n) 0.45 1) [0..n-1]
    where n=12


test2 :: FilePath -> Identicon -> IO ()
test2 path ident=withImageSurface FormatRGB24 size size $ \s->renderWith s r >> surfaceWriteToPNG s path
    where r=do
              scale (fromIntegral size) (fromIntegral size)
              render ident
          size=36

testAll :: IO ()
testAll=mapM_ (\(ix,b)->test (printf "prim%03d.png" ix) b) $ zip ([1..] :: [Int]) defaultBlocks

test :: FilePath -> Block -> IO ()
test path block=withImageSurface FormatRGB24 size size $ \s->renderWith s r >> surfaceWriteToPNG s path
    where r=do
              scale (fromIntegral size) (fromIntegral size)
              
              setSourceRGB 0 0 0
              rectangle 0 0 1 1
              fill
            
              setSourceRGB 1 0 0
              renderBlock block
              fill
          size=32


-- | Identicon instance
data Identicon=Identicon Color Block Block Block deriving(Show,Eq)

numIdenticon :: Integer
numIdenticon=(fromIntegral $ length defaultBlocks)^3*(fromIntegral $ length defaultColors)

mapIdenticon :: Integer -> Identicon
mapIdenticon x=Identicon (appC per) (appB corner) (appB edge) (appB mid)
    where
        appB=(defaultBlocks!!)
        appC=(defaultColors!!)
    
        [per,corner,edge,mid]=decompose [m,n,n,n] x
        n=length defaultBlocks
        m=length defaultColors

decompose :: [Int] -> Integer -> [Int]
decompose [] x=[]
decompose (b:bs) x=fromIntegral m:decompose bs q
    where (q,m)=x `divMod` (fromIntegral b)


render :: Identicon -> Render ()
render (Identicon per c e m)=do
    setSourceColor $ RGB 1 1 1
    rectangle 0 0 1 1
    fill
    
    setSourceColor per
    zipWithM_ renderB table ss
    withinRegion 3 3 1 1 $ renderMid m
    fill
    where
        renderB (x,y) block=withinRegion 3 3 x y $ renderBlock block
        
        ss=[r0 c,r0 e,r1 c
           ,r3 e     ,r1 e
           ,r3 c,r2 e,r2 c]
        
        [r0,r1,r2,r3]=take 4 $ iterate (.rotateB) id
        table=[(x,y)|y<-[0,1,2],x<-[0,1,2],x/=1||y/=1]

renderMid m=mapM_ (uncurry renderB) $ zip [(0,0),(1,0),(1,1),(0,1)] $ take 4 $ iterate rotateB m
    where renderB (x,y) block=withinRegion 2 2 x y $ renderBlock block

withinRegion :: Int -> Int -> Int -> Int -> Render a -> Render a
withinRegion nx ny x y f=do
    save
    scale (1/fromIntegral nx) (1/fromIntegral ny)
    translate (fromIntegral x) (fromIntegral y)
    r<-f
    restore
    return r


-- | Unified color
data Color=RGB !Double !Double !Double deriving(Show,Eq)

rgbColor,hsvColor :: Double -> Double -> Double -> Color
rgbColor r g b=RGB r g b
hsvColor h s v=case i `mod` 6 of
    0 -> RGB v t p
    1 -> RGB q v t
    2 -> RGB p v t
    3 -> RGB p q v
    4 -> RGB t p v
    5 -> RGB v p q
    where
        (i,f)=properFraction $ h*6
        
        p=v*(1-s)
        q=v*(1-s*f)
        t=v*(1-s*(1-f))

setSourceColor :: Color -> Render ()
setSourceColor (RGB r g b)=setSourceRGB r g b

setSourceColorA :: Color -> Double -> Render ()
setSourceColorA (RGB r g b) alpha=setSourceRGBA r g b alpha


-- | Primitive shape
--   points' locations are:
--    0  1  2
--    3  4  5
--    6  7  8
newtype Block=Block [Int] deriving(Show)

-- | This is not complete. (ie:0,1,2 and 0,2)
instance Eq Block where
    (Block xs) == (Block ys)
        |length xs/=length ys = False
        |otherwise            = isInfixOf xs (ys++ys) || isInfixOf (reverse xs) (ys++ys)

-- maximum of 8 patterns (rot:4 * rev:2)
expand :: Block -> [Block]
expand block=nub $ map ($block) syms
    where
        syms=rots++map (.reverseB) rots
        rots=take 4 $ iterate (.rotateB) id

renderBlock :: Block -> Render ()
renderBlock (Block (x:xs))=do
    uncurry moveTo (table!!x)
    mapM_ (uncurry lineTo . (table!!)) xs
    closePath
    where table=[(0.5*fromIntegral x,0.5*fromIntegral y)|y<-[0,1,2],x<-[0,1,2]]

rotateB (Block xs)=Block $ map ([2,5,8,1,4,7,0,3,6]!!) xs
reverseB (Block xs)=Block $ map ([2,1,0,5,4,3,8,7,6]!!) xs