Array.hs

-- |
-- Module: Graphics.Chalkboard.Array
-- Copyright: (c) 2009 Andy Gill
-- License: BSD3
--
-- Maintainer: Andy Gill <andygill@ku.edu>
-- Stability: unstable
-- Portability: ghc
--
-- This module coverts 2D arrays into 'Board's, and back, and supplies basic dithering algorithms.

module Graphics.Chalkboard.Array
	( -- * Converters
	  boardToArray, arrayToBoard,
	  -- * Dithering
	 threshold, floydSteinberg
	)
 where

import Data.Array

import Graphics.Chalkboard.Board as Board
import Graphics.Chalkboard.Utils
import Graphics.Chalkboard.Types

import Control.Applicative

-- | 'boardToArray' turns a Board into a 2D Array (pixelization).

boardToArray :: (Average a) 
 => (Int,Int) 	-- ^ the x,y size of the image to be captured. We assume the bottom left hand size is 0,0.
 -> Int       	-- ^ the square root of the amount of super-sampling to be done. I recommend 3, which is 9 points.
 -> Board a	-- ^ the board to sample.
 -> Array (Int,Int) a -- ^ the result array.
boardToArray (x_dim,y_dim) n board = array ((0,0),(x_dim,y_dim))
	[ ((x,y), average 
		   [ fn (fromIntegral x + x',fromIntegral y + y') 
		   | x' <- innerSteps n 
		   , y' <- innerSteps n
		   ]
	   )
	| x <- [0..x_dim]
	, y <- [0..y_dim]
 	]
    where
	fn = Board.lookup board

-- There are different ways of taking a 2d array into a Board.
--   * Do you pixelize the input, or make it continuous (using Bilinear interpolation)?
--   * Be careful at the edges! You want the samples to be inside the actual edge, not on it.
--  How do we handle the alpha at the edges!
{-

   0       1       2
   +---X---+---Y---+

   So, with pixels, what value does 1 have (X or Y), how about 0 and 2, do you biest to the left or right?
       with continuous, what value does 0 or 2 have?

-}

-- | 'arrayToBoard' turns a 2D Array into a Board, using bi-linear inteprelation.

arrayToBoard :: (Lerp a, Scale a) => Array (Int,Int) a -> Board (Maybe a)
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
  where 
	(width,height) = (w-1,h-1)
	outside x0 y0 = x0 < 0
		     || x0 > fromIntegral width
	             || y0 < 0
		     || y0 > fromIntegral height
	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
				= Nothing
			    | otherwise
				= Just (arr ! (x0,y0))
		 p00 = find x' y'
		 p10 = find (succ x') y'
		 p01 = find x' (succ y')
		 p11 = find (succ x') (succ y')
		 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)

		

-- how close are you to one of our samples?
close :: R -> (Int,R)
close v0 = (v_floor,fracPart v0)
  where
	v_floor = floor v0


------------------------------------------------------
-- | 'threshold' quantized based on a simple, pointwise function.

threshold :: (Floating a) => (a -> a) -> Array (Int,Int) a -> Array (Int,Int) a
threshold quantize = fmap quantize

-- | 'floydSteinberg' quantized using the Floyd Steinberg algorithm.

floydSteinberg :: (Floating a) => (a -> a) -> Array (Int,Int) a -> Array (Int,Int) a
floydSteinberg quantize orig = fmap fst values
  where
	bnds@((x_min,y_min),(x_max,y_max)) = bounds orig 
	errors (x,y) | inRange bnds (x,y) = snd (values ! (x,y))
		     | otherwise    = 0
	values = array bnds
		[ let value = orig ! (x,y) +
			(errors (x-1,y))   * 7 +
			(errors (x+1,y-1)) * 3 +
			(errors (x,y-1))   * 5 +
			(errors (x-1,y-1)) * 1
		      q_value = quantize value
		  in ((x,y),(q_value,(value - q_value) / 16))
		| x <- [x_min..x_max]
		, y <- [y_min..y_max]
		]