chalkboard-0.1: test/Test.hs

import Graphics.Chalkboard

import Control.Applicative

import System.Environment

main = do
	args <- getArgs
	(brd,(x,y)) <- readPPM "liam.ppm"
	let img = mainWithArgs args brd
	let file = case args of 
		     [] ->     "blank"
		     (nm:_) -> nm
	writePPM (file ++ ".ppm") (200,200) $ move (100,100) $ img

cutandpaste :: (Over a) => (Point,Point) -> Board a -> Board a -> Board a
cutandpaste (p1,p2) b1 b2 = pure choose
					<*> b1
					<*> b2
					<*> fmap (insideRegion (p1,p2)) coord

--border :: ((x1,y1),(x2,y2)) b1 = pure (\ 


foldOntoFilm :: (Over a) => (Point,Point) -> Board a -> [Board a] -> Board a
foldOntoFilm s@((x1,y1),(x2,y2)) back xs = foldr (\ b bk -> cutandpaste s b (move (x2-x1,0) bk)) back xs


mainWithArgs :: [String] -> Board (Maybe RGB) -> Board RGB
mainWithArgs ["chess"] bk = fmap (\ x -> if x then green else white) $ rotate 0.05 $ scale 50 $ checker 
mainWithArgs ["chessfilm"] bk = 
	id
	$ move (-70,0)
	$ scale 5
	$ foldOntoFilm 
		((-5,-5),(5,5)) 
		(pure white)
		[ fmap (\ x -> if x then green else white) $ rotate n $ checker  
		| n <- take 10 [0.0,0.02..]
		]
mainWithArgs ["liam2"] bk = id
       			$ scale 2
       			$ move (-50,-50)
			$ fmap (withDefault white) bk
mainWithArgs ["pattern"] bk = fmap unAlpha (foldr over p2 
			    [ rotate (fromIntegral n / 5) p1
			    | n <- [0..5]
			    ])
  where
    p1, p2 :: Board (Alpha RGB)
    p2 = pure (alpha white)
    p1 = id
	$ fmap (withAlpha 0.4)
	$ scale 50
	$ pure (\ (x,y) -> lerp red green ((1 + ((fracPart x - fracPart y) :: R)) / 3)) <*> coord
mainWithArgs ["sinwaves",n] bk = id
		$ move (-100,0) 
	    	$ fmap unAlpha 
		$ stack $
		[ fmap (choose (withAlpha 0.8 col) 
			       (transparent white))
			$ functionline (\ x -> (x * 400,t + 80 * x * sin (x * t))) 3 count
		| (col,t) <- zip [red,green,blue] [16,18,20]
	 	] ++ 
	    	[ fmap (choose (withAlpha 0.8 col) 
			       (transparent white))
	 		$ functionline (\ x -> (400 - x * 400,t - 80 * x * sin (x * t))) 3 count
		| (col,t) <- zip [cyan,purple,yellow] [15,17,20]
		] ++ 
		[ pure (alpha white) ]
	where count = read n
mainWithArgs ["arrows",n] nk =
		  fmap (withDefault white)
		$ stack
		([ stack
		    [fmap (choose (Just red) Nothing)
		  	  $ stack
		 	  [ straightline (p1,p2) 1
			  , arrowhead p1 (angleOfLine (p2,p1)) 10
			  , arrowhead p2 (angleOfLine (p1,p2)) 10
		    	  ]
		    ]
		| (p1,p2) <- [ ((10,10),(50,50))
			     , ((-20,20),(53,80))
			     , ((43,-85),(-25,-20))
			     ]
		] ++
		[ fmap (choose (Just green) Nothing)
		  	  $ stack
		 	  [ functionline f 1 count
			  , arrowhead (f 0) (angleOfLine (f nearZero,f 0)) 10
			  , arrowhead (f 1) (angleOfLine (f (1 - nearZero),f 1)) 10
		    	  ]
		| f <- [ \ x -> (x * x * 50 + 20,x * 50)
		       , \ x -> (80 * (0.1 + x) * sin (x * pi * 20),80 * (0.1 + x) * cos (x * pi * 20))
		       ]
 		])
	where count = read n
mainWithArgs _         bk = pure white