chalkboard 0.1 → 0.2

raw patch · 7 files changed

+83/−134 lines, 7 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Graphics/Chalkboard/Array.hs +15/−11
• Graphics/Chalkboard/Color.hs +2/−0
• Graphics/Chalkboard/PPM.hs +42/−12
• Graphics/Chalkboard/Shapes.hs +2/−1
• Graphics/Chalkboard/Types.hs +8/−2
• chalkboard.cabal +14/−9
• test/Test.hs +0/−99

@@ -13,7 +13,9 @@ 	( -- * Converters 	  boardToArray, arrayToBoard, 	  -- * Dithering-	 threshold, floydSteinberg+	  threshold, floydSteinberg,+	  -- * Utilties+	  widthHeight 	)  where @@ -65,19 +67,18 @@ arrayToBoard arr = arrayToBoard' arr (bounds arr)  arrayToBoard' :: (Lerp a, Scale a) => Array (Int,Int) a -> ((Int,Int),(Int,Int)) -> Board (Maybe a)-arrayToBoard' arr ((0,0),(w,h)) = pure img <*> coord+arrayToBoard' arr bnd@((0,0),(w,h)) = pure img <*> coord   where -	(width,height) = (w-1,h-1) 	outside x0 y0 = x0 < 0-		     || x0 > fromIntegral width+		     || x0 > fromIntegral w 	             || y0 < 0-		     || y0 > fromIntegral height+		     || y0 > fromIntegral h 	img (x,y) | outside x y = Nothing 	          | otherwise   = lerp p00_p10 p01_p11 y_gap 		where-		 (x',x_gap) = close x -		 (y',y_gap) = close y -		 find x0 y0 | outside x0 y0+		 (x',x_gap) = close (x - 0.5) +		 (y',y_gap) = close (y - 0.5) +		 find x0 y0 | not (inRange bnd (x0,y0)) 				= Nothing 			    | otherwise 				= Just (arr ! (x0,y0))@@ -88,16 +89,19 @@ 		 p00_p10 = lerp p00 p10 x_gap 		 p01_p11 = lerp p01 p11 x_gap -- normalize the board to start at (0,0)-arrayToBoard' arr bnds@((low_w,low_h),_) = arrayToBoard (ixmap bnds (\ (w,h) -> (w - low_w,h - low_h)) arr)--		+arrayToBoard' arr bnds@((low_w,low_h),_) = arrayToBoard (ixmap bnds (\ (w,h) -> (w - low_w,h - low_h)) arr)	  -- how close are you to one of our samples? close :: R -> (Int,R) close v0 = (v_floor,fracPart v0)   where 	v_floor = floor v0+------------------------------------------------------ +widthHeight :: Array ((Int,Int)) a -> (Int,Int)+widthHeight arr = (w+1,h+1)+	where+		((0,0),(w,h)) = bounds arr  ------------------------------------------------------ -- | 'threshold' quantized based on a simple, pointwise function.

@@ -22,6 +22,7 @@ ------------------------------------------------------------------------------  -- | 'Gray' is just a value between 0 and 1, inclusive.+-- Be careful to consider if this is pre or post gamma. type Gray = UI  @@ -56,6 +57,7 @@ 	reds   = [ r | RGB r _ _ <- cs ] 	greens = [ g | RGB _ g _ <- cs ] 	blues  = [ b | RGB _ _ b <- cs ]+   red    :: RGB

@@ -7,7 +7,7 @@ -- Stability: unstable -- Portability: ghc ----- Reading and writing portable pix maps. For now, we only support color images (@P3@ and @P6@ formats).+-- Reading and writing portable pix maps. For now, we only support color images (@P1@, @P3@ and @P6@ formats). --  module Graphics.Chalkboard.PPM where@@ -18,13 +18,11 @@  import Graphics.Chalkboard.Types import Graphics.Chalkboard.Color-import Graphics.Chalkboard.Board import Graphics.Chalkboard.Array   -- | 'readPPM' reads a PPM file, and outputs a @Board@, and the @x@ and @y@ dimensions of the image.--readPPM :: String -> IO (Board (Maybe RGB),(Int,Int))+readPPM :: String -> IO (Array (Int,Int) RGB) readPPM filename = do 	h <- openFile filename ReadMode 	ty <- hGetLine h@@ -52,21 +50,53 @@ 		| (row,h') <- zip num_rows [height-1,height-2..] 		, ([r,g,b],w) <- zip row [0..] 		]-	return $ (arrayToBoard arr,(width,height))+	return $ arr -- (arrayToBoard arr,(width,height)) --- | 'writePPM' writes a PPM file, based on a color @Board@, where bottom left corner of the image is as @(0,0)@. -writePPM :: String -> (Int,Int) -> Board RGB -> IO ()-writePPM filename (x_dim,y_dim) img = writeFile filename $ -	"P6\n" ++ show (x_dim) ++ " " ++ show (y_dim) ++ "\n255\n" +++-- | 'readBPM' reads a PPM file, and outputs a @Board@, and the @x@ and @y@ dimensions of the image.+readPBM :: String -> IO (Array (Int,Int) Bool)+readPBM filename = do+	h <- openFile filename ReadMode+	ty <- hGetLine h+	_bin <- case ty of+	   "P1" -> return False+	   "P4" -> error "P4 PBM format not (yet) supported"+	   _ -> error $ "bad PPM format: " ++ ty+	szs <- hGetLine h+	let [width,height] = (map read (words szs) :: [Int])+--	print width+--	print height   +-- 	mx <- hGetLine h+--	let [maxs] = (map read (words mx) :: [R])+--	print mx+	str <- hGetContents h+	let num1 = map (\ x -> if x == '1' then True else+		                 if x == '0' then False +		                 else error $ "bad data inside P1 file" ++ show x) +		$ filter (not . isSpace) str+	let joinN _ [] = []+	    joinN n xs = take n xs : joinN n (drop n xs)+        let num_rows = joinN width num1+	let arr = array ((0,0),(width-1,height-1))+		[ ((w,h'),v)+		| (row,h') <- zip num_rows [height-1,height-2..]+		, (v,w) <- zip row [0..]+		]+	return $ arr -- (arrayToBoard arr,(width,height))++-- | 'writePPM' writes a PPM file, based on a color @Board@, where bottom left corner of the image is as @(0,0)@.+writePPM :: String -> Array (Int,Int) RGB -> IO ()+writePPM filename arr = writeFile filename $ +	"P6\n" ++ show w ++ " " ++ show h ++ "\n255\n" ++ 	concat 	[ let (RGB r g b) = arr ! (x,y) 	      f x' =  if v < 0 then chr 0 else 	              if v > 255 then chr 255 else chr v 		 where v = floor (x' * 255) 	  in [f r,f g,f b]-	| y <- reverse [0..y_dim-1]-	, x <- [0..x_dim-1]+	| y <- reverse [0..(h-1)]+	, x <- [0..(w - 1)] 	]-   where arr = boardToArray (x_dim-1,y_dim-1) 3 img+   where (w,h) = widthHeight arr+	 	

@@ -56,9 +56,10 @@  functionline :: (R -> Point) -> R -> Int -> Board Bool functionline line width steps = stack-		 [ straightline (p1,p2) width+		[ straightline (p1,p2) width 		| (p1,p2) <- zip samples (tail samples) 		] `over` stack+		        -- not the first or last point 		[ dotAt p | p <- tail (init samples) ]     where 	samples = map line (outerSteps steps)

@@ -120,8 +120,8 @@ alpha c = Alpha c 1.0  -- | 'transparent' builds something that has an alpha channel, and is completely transparent.-transparent :: c -> Alpha c-transparent c = Alpha c 0.0+transparent :: (Scale c) => c -> Alpha c+transparent c = Alpha (scale 0 c) 0.0  -- | 'withAlpha' builds somethings that has a specific alpha value. withAlpha :: (Scale c) => UI -> c -> Alpha c@@ -139,6 +139,12 @@      where 	-- can a_new be 0? only if a == 0 and a' == 0 	a_new     = a + a' * (1 - a)++instance Lerp c => Lerp (Alpha c) where+  lerp (Alpha c1 a1) (Alpha c2 a2) s = Alpha (lerp c1 c2 s) (lerp a1 a2 s)+  +instance Scale c => Scale (Alpha c) where+  scale s (Alpha c t) = Alpha (scale s c) (scale s t)  ------------------------------------------------------------------------------ 

@@ -1,5 +1,5 @@ Name:                chalkboard-Version:             0.1+Version:             0.2 Synopsis:            Combinators for building and processing 2D images.  Description:	     Chalkboard is a Haskell hosted Domain Specific Language (DSL) for image generation and processing. 		The basic structure is a chalk board, a two-dimensional canvas of values, typically colors. @@ -37,11 +37,16 @@    Ghc-Options:  -Wall -Executable chalkboard-test-  Build-Depends:        base, array-  Ghc-Options:    -O2-  Main-Is:        Test.hs-  Hs-Source-Dirs: ., test-  buildable: True--+--Executable chalkboard-test+--  Build-Depends:        base, array, process+--  Ghc-Options:    -O2+--  Main-Is:        Test.hs+--  Hs-Source-Dirs: ., test+--  buildable: True+--+--Executable chalkboard-test2+--  Build-Depends:        base, array, process+--  Ghc-Options:    -O2+--  Main-Is:        Test2.hs+--  Hs-Source-Dirs: ., test+--  buildable: True

@@ -1,99 +0,0 @@-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