module Graphics.Captcha (makeCaptcha) where

import Data.ByteString
import Data.Char
import Graphics.GD
import System.Random


main :: IO ()
main = do
  string <- makeRandomString
  image <- createInitialImage string
  chirpDoubleRandom image
  chirpDoubleRandom image
  image <- cropToFinalSize image
  Prelude.putStrLn string
  savePngFile "captcha.png" image


makeCaptcha :: IO (String, ByteString)
makeCaptcha = do
  string <- makeRandomString
  image <- createInitialImage string
  chirpDoubleRandom image
  chirpDoubleRandom image
  image <- cropToFinalSize image
  byteString <- savePngByteString image
  return (string, byteString)


makeRandomString :: IO String
makeRandomString = do
  let makeRandomLetter = do
                     n <- randomRIO (0, 25)
                     return $ chr (ord 'A' + n)
  mapM (\_ -> makeRandomLetter) [0..5]


chirpDoubleRandom :: Image -> IO ()
chirpDoubleRandom image = do
  depth1 <- randomRIO (2.0, 5.0)
  period1 <- randomRIO (1, 6)
  period2 <- randomRIO (1, 6)
  depth2 <- randomRIO (2.0, 5.0)
  period3 <- randomRIO (1, 6)
  period4 <- randomRIO (1, 6)
  chirpVertically (makeChirpFunction depth1
                                     (fromIntegral captchaSize / period1)
                                     (fromIntegral captchaSize / period2))
                  image
  chirpHorizontally (makeChirpFunction depth2
                                       (fromIntegral captchaSize / period3)
                                       (fromIntegral captchaSize / period4))
                    image


chirpHorizontally :: (Int -> Int) -> Image -> IO ()
chirpHorizontally chirpFunction image = do
  withImage (newImage (captchaSize, captchaSize))
            (\temporaryImage -> do
               copyRegion (0, 0) (captchaSize, captchaSize) image
                          (0, 0) temporaryImage
               let shiftRow row amount
                       = copyRegion (0, row) (captchaSize, 1) image
                                    (amount, row) temporaryImage
                   shiftRows function
                       = shiftRows' 0 function
                   shiftRows' i function
                       = if i == captchaSize
                            then return ()
                            else do
                              shiftRow i (function i)
                              shiftRows' (i+1) function
               shiftRows chirpFunction
               copyRegion (0, 0) (captchaSize, captchaSize) temporaryImage
                          (0, 0) image)


chirpVertically :: (Int -> Int) -> Image -> IO ()
chirpVertically chirpFunction image = do
  withImage (newImage (captchaSize, captchaSize))
            (\temporaryImage -> do
               copyRegion (0, 0) (captchaSize, captchaSize) image
                          (0, 0) temporaryImage
               let shiftColumn column amount
                       = copyRegion (column, 0) (1, captchaSize) image
                                    (column, amount) temporaryImage
                   shiftColumns function
                       = shiftColumns' 0 function
                   shiftColumns' i function
                       = if i == captchaSize
                            then return ()
                            else do
                              shiftColumn i (function i)
                              shiftColumns' (i+1) function
               shiftColumns chirpFunction
               copyRegion (0, 0) (captchaSize, captchaSize) temporaryImage
                          (0, 0) image)


makeChirpFunction :: Float -> Float -> Float -> Int -> Int
makeChirpFunction depth startingWaveLength endingWaveLength row
    = let waveLength = ((startingWaveLength * fromIntegral row)
                        + (endingWaveLength * fromIntegral (captchaSize - row)))
                       / fromIntegral captchaSize
      in floor $ depth * (sin $ (fromIntegral row) * ((2*pi) / waveLength))


createInitialImage :: String -> IO Image
createInitialImage string = do
  image <- newImage (captchaSize, captchaSize)
  useFontConfig True
  drawFilledRectangle (0, 0) (captchaSize, captchaSize) 0xFFFFFF image
  ((left, top), _, (right, bottom), _)
      <- measureString fontName fontSize 0.0 (0, 0) string 0x000000
  width <- return $ right - left
  height <- return $ top - bottom
  originX <- return $ (captchaSize - width) `div` 2
  originY <- return $ (captchaSize + height) `div` 2
  drawString fontName fontSize 0.0 (originX, originY) string 0x000000 image
  return image


cropToFinalSize :: Image -> IO Image
cropToFinalSize image = do
  result <- newImage finalSize
  copyRegion ((captchaSize - fst finalSize) `div` 2,
              (captchaSize - snd finalSize) `div` 2)
             finalSize
             image
             (0, 0)
             result
  return result


fontName :: String
fontName = "Courier New"


fontSize :: Double
fontSize = 22.0


captchaSize :: Int
captchaSize = 192


finalSize :: (Int, Int)
finalSize = (128, 64)