module GTest where

import Graphics
import GraphicsColor

-- This import decl reveals a Hugs bug
-- import GraphicsBrush(RGB(RGB))

import GraphicsPicture

-- import Region
import GraphicsRegion 

import List(nub)
import Array

import Concurrent

----------------------------------------------------------------

myPar :: [IO ()] -> IO ()
myPar ms = foldr par (return ()) ms
 where
  par m1 m2 = do
    v1 <- newEmptyMVar 
    v2 <- newEmptyMVar 
    forkIO (m1 >> putMVar v1 ())
    forkIO (m2 >> putMVar v2 ())
    takeMVar v1
    takeMVar v2
    return ()

----------------------------------------------------------------

-- abbreviation for runGraphics - almost all tests that you run
-- will be of the form "rg w<n>" for some small positive n
rg = runGraphics

main = runGraphics $ myPar [w1,w2,w3,w4,w5,w6 p1,w7,w8,w9,w10]

w1 = do
	w <- openWindow "My First Graphics Program" (400,400)
	draw w $ text (150,200) "Hello Graphics Window 1"
	getLBP w
	draw w $ text (150,250) "Hit a key" 
	getKey w
	clearWindow w 
	draw w $ text (150,200) "Thank you"
        draw w $ text (150,250) "Hit another key"
	getKey w
	closeWindow w

w2 = do
	w <- openWindow "My Second Graphics Program" (400,400)
	draw w $ text (150,200) "Hello Graphics Window 2"
	getRBP w
	draw w $ text (150,250) "Hit a key" 
	getKey w
	clearWindow w 
	draw w $ text (150,200) "Thank you"
        draw w $ text (150,250) "Hit another key"
	getKey w
	closeWindow w

----------------------------------------------------------------
-- Region demo
----------------------------------------------------------------

r1 = unions
	[ Shape (Rect    (000,000) (300,100))
	, Shape (Ellipse (100,000) (200,500))
	]
r2 = Shape (Rect (050,050) (250,150))
r3 = r1 `Intersect` r2
r4 = pentangle 0

pentangle :: Angle -> MyRegion
pentangle phi = poly phi (4*pi/5) 5

triangle :: Angle -> MyRegion
triangle phi = poly phi (2*pi/3) 3 

-- draw a regular polygon with "n" sides "angle" apart 
poly :: Angle -> Angle -> Int -> MyRegion
poly init delta n = Shape (Polygon vertices)
 where
  thetas   = take n [init, init+delta ..]
  vertices = [ (round x, round y)
             | theta <- thetas 
             , let x = 200*(1+cos theta)
	     , let y = 200*(1+sin theta)
             ]

----------------------------------------------------------------

w3 = do
	w <- openWindow "Regions demo" (300,500)
	mapM_ (\ r -> do
                        setPicture w (drawRegion r)
                  	getLBP w)
              [r1,r2,r3,r4]
	clearWindow w
	draw w $ text (150,250) "Hit a key" 
	getKey w
	closeWindow w

w4 = do 
	wa <- openWindow "Multiwindow demo 1" (300,500)
	wb <- openWindow "Multiwindow demo 2" (300,500)

        draw wa $ text (100,100) "Hello World 1"
        draw wb $ text (100,100) "Hello World 2"

	ka <- getKey wa
        draw wb $ text (100,200) ("Got key " ++ [ka])

	kb <- getKey wb
        draw wa $ text (100,200) ("Got key " ++ [kb])

	closeWindow wa
	closeWindow wb

----------------------------------------------------------------
-- Picture demo
----------------------------------------------------------------

type Pic color = [(color, MyRegion)] 

p1 = [ (Red,r3), (Green, r2), (Blue, r1)]

w5 = do
	w <- openWindow "Picture demo" (300,500)
	setPicture w (drawPic p1)
        getLBP w
	clearWindow w
	draw w $ text (150,250) "Hit a key" 
	getKey w
	closeWindow w

drawPic :: Pic Color -> Picture
drawPic p = overMany [ withColor c $ drawRegion r | (c,r) <- p ]

----------------------------------------------------------------
-- Faster picture drawing
----------------------------------------------------------------

-- This version is more efficient because it allocates colors just once.
--
-- The cost of this performance gain is that we have to expose the
-- allocation and deallocation of brushes to the programmer, which 
-- makes it possible for them to deallocate too early, to deallocate
-- too late (eg never), or to deallocate too often.
--
-- Notice that you must not deallocate brushes (and fonts, etc)
-- until _after_ you clear the screen - otherwise the redraw routine
-- might be called and you'll have a dangling reference to the brush.

w6 p = do
	w <- openWindow "Faster Picture Demo" (300,500)

	-- get the "palette"
	let colors  =  nub [ c | (c,r) <- p ]
	brushes     <- mapM (\c -> createBrush (colorTable ! c)) colors
	let palette =  array (minBound,maxBound) (zip colors brushes)
	let pic     =  [ (palette!c, r) | (c,r) <- p ]

	setPicture w (drawPic2 pic)
        getLBP w

	clearWindow w
	mapM_ deleteBrush brushes -- delete brushes after clearWindow

	draw w $ text (150,250) "Hit a key" 
	getKey w
	closeWindow w

drawPic2 :: Pic Brush -> Picture
drawPic2 p = overMany [ withBrush b (drawRegion r) | (b,r) <- p ]

----------------------------------------------------------------
-- Animation (sort of)
--
-- Simple animations made of lists of pictures
----------------------------------------------------------------

type Frame = Pic Color
type Anim  = [Frame]

a1 :: Anim
a1 = [ [(Red,   pentangle phi)
       ,(Green, triangle  (-phi))
       ]
     | phi <- [0, pi/20 .. 2*pi] 
     ]

-- draw an animation (using user-input to step through animation)
w7 = do
	w <- openWindow "Animation demo" (400,400)
	mapM_ (drawFrame w) a1
 where
  -- draw a frame and wait for left button press
  drawFrame :: Window -> Frame -> IO ()
  drawFrame w p = do
	  setPicture w (drawPic p)
	  getLBP w
	  return ()

----------------------------------------------------------------
-- Timer demo
----------------------------------------------------------------

-- draw an animation (using timer to step through animation)
w8 = do
	w <- openWindowEx "Timer demo" Nothing (Just (400,400))
                          drawBufferedPicture (Just 50)
	mapM_ (drawFrame w) (cycle a1)
 where
  -- draw a frame and wait for a tick
  drawFrame :: Window -> Frame -> IO ()
  drawFrame w p = do
	setPicture w (drawPic p)
	getTick w

----------------------------------------------------------------
-- Text demo
----------------------------------------------------------------

-- half-inch wide, red text on a transparent background at a 45 degree angle
-- quarter-inch wide, red text on a green background at a -45 degree angle
w9 = do
	w <- openWindow "Font demo" (500,500)
	font1 <- createFont (50,50)  (pi/4)  False False "Arial"
	font2 <- createFont (25,50) (-pi/4) True True   "Times New Roman"
        draw w
          $ withTextColor (RGB 255 0 0)
          $ withFont font1
          $ withBkMode Transparent
  	  $ text (050,450) "Font Test 1"
        draw w
          $ withTextColor (RGB 0 0 255)
          $ withFont font2 
	  $ withBkColor (RGB 0 255 0)
  	  $ text (050,050) "Font Test 2"
	getLBP w
	deleteFont font1
	deleteFont font2
	closeWindow w

----------------------------------------------------------------
-- Error catching demo
----------------------------------------------------------------

-- This program demonstrates that the system doesn't get left in
-- an inconsistent state even if your program hits an error.

w10 = do
	w <- openWindow "Error recovery demo" (300,300)
        draw w
  	  $ text (10,150) "Click me to test error recovery"
	getLBP w
        draw w $ error "foo1"
	--error "foo2"
	getLBP w
	clearWindow w
        draw w
  	  $ text (10,150) "Shouldn't have made it this far"
	getLBP w
	closeWindow w

----------------------------------------------------------------
-- Bitmap demo
----------------------------------------------------------------

w11 = do
	w <- openWindow "Bitmap demo" (300,500)
	setPicture w $ 
          text (150,200) "Test"
          `over`
          drawPic p1
	savePicture "bitmaps/Foo.bmp" (300,500) $ 
          text (150,200) "Test"
          `over`
          drawPic p1
        getLBP w
	closeWindow w

w11b = do
	(bmp,_) <- loadBitmap "bitmaps/Foo.bmp" 
	w <- openWindow "Bitmap demo" (300,500)
	setPicture w $ bitmap (50,50) bmp
	getKey w
	closeWindow w

w11c = do
	(bmp,_) <- loadBitmap "bitmaps/Foo.bmp" 
	w <- openWindow "Bitmap demo" (300,500)
	setPicture w $ stretchBitmap (0,400) (400,0) bmp
	getKey w
	closeWindow w


w12 = do
	w <- openWindow "Bitmap demo" (400,400)
	mapM_ (drawFrame w) (zip [100..] a1)
 where
  -- draw a frame and wait for left button press
  drawFrame :: Window -> (Int,Frame) -> IO ()
  drawFrame w (i,p) = do
	  setPicture w $ drawPic p
 	  savePicture name (400,400) $ drawPic p
	  getLBP w
	  return ()
   where
    name = "bitmaps/" ++ "Foo" ++ show i ++ ".bmp"


----------------------------------------------------------------
-- Examples from the documentation
----------------------------------------------------------------

demos :: IO ()
demos = runGraphics $ myPar
  [ helloWorld
  , eg cp
  , fontDemo
  , lineDemo 0
  , lineDemo 1
  , lineDemo 20
  , keyTest
  , timerDemo
  , ellipseTest
  ]

helloWorld :: IO ()
helloWorld = do
	  w <- openWindow "Hello World Window" (300, 300)
	  draw w $ text (100, 100) "Hello"
	  draw w $ text (100, 200) "World"
	  getKey w
	  closeWindow w

cp :: Picture
cp = 
     mkBrush (colorTable!Red)  $ \ red  ->
     mkBrush (colorTable!Blue) $ \ blue ->
     over
       (withBrush red  $ polygon [(200,200),(400,200),(300,400)])
       (withBrush blue $ polygon [(100,100),(500,100),(500,500),(100,500)])

eg :: Picture -> IO ()
eg p = do
	  w <- openWindow "Hello World Window" (600,600)
	  draw w p
	  getKey w
	  closeWindow w

fontDemo :: IO ()
fontDemo = do
  w <- openWindow "Font Demo Window" (500,500)
  draw w $
    withTextColor (RGB 255 0 0)           $
    mkFont (50,100) (pi/4) False True "Arial"  $ \ font ->
    withFont font		          $
    withBkColor (RGB 0 255 0)             $
    withBkMode Opaque         	          $
    text (050,450) "Font Demo"
  getKey w
  closeWindow w

-- Note that "width" must be 1 or less for the penstyle to matter

lineDemo :: Int -> IO ()
lineDemo width = do
  w <- openWindow ("Line Demo Window " ++ show width) (500,500)
  draw w $
    let 
      color = colorTable ! Red 
    in
    mkPen Solid      width color $ \ pen1 ->
    mkPen Dash       width color $ \ pen2 ->
    mkPen Dot        width color $ \ pen3 ->
    mkPen DashDotDot width color $ \ pen4 ->
    overMany 
      [ withPen pen1 $ line (100,100) (400,100)
      , withPen pen2 $ line (100,200) (400,200)
      , withPen pen3 $ line (100,300) (400,300)
      , withPen pen4 $ line (100,400) (400,400)
      ]
  getKey w
  closeWindow w

-- Just what keys can we see?
keyTest :: IO ()
keyTest= do
  w <- openWindow "Keypress Demo Window" (500,500)
  c <- getKey w
  print (fromEnum c)
  closeWindow w


-- Tick counter
timerDemo = do
  w <- openWindowEx 
         "Timer demo"         -- title
         (Just (500,500))     -- initial position of window
         Nothing -- (Just (100,100))     -- initial size of window
         drawFun              -- draw function - see below
         (Just 50)            -- tick rate
  let
    loop x = do
      setPicture w $ text (0,50) $ show x
      getTick w            -- wait for next tick on window
      loop (x+1)
  loop 0
 where

  -- The possible choices of "drawFun" are
  --
  -- o drawBufferedPicture - use a double buffer to reduce animation flicker
  -- o drawPicture         - draw directly to screen (for speed)
  
  useDoubleBuffering = True

  drawFun = if useDoubleBuffering then
               drawBufferedPicture
            else
               drawPicture

ellipseTest :: IO ()
ellipseTest = do
	  w <- openWindow "Ellipse Test" (300, 300)
	  draw w $ ellipse (0,0) (200, 100)
	  getKey w
	  closeWindow w


----------------------------------------------------------------
-- Region code - prototype of the code in SOE
----------------------------------------------------------------

{-
module Region(
	MyRegion(Empty, Union, Intersect, Shape),
	unions,
	Shape(Rect, Ellipse, Polygon),
	drawRegion
	) where

import GraphicsRegion
-}

data MyRegion
  = Empty
  | Union     MyRegion MyRegion
  | Intersect MyRegion MyRegion
  | Shape     Shape

unions :: [MyRegion] -> MyRegion
unions = foldr Union Empty 

--intersects :: [MyRegion] -> MyRegion
--intersects = foldr Intersect Full

drawRegion :: MyRegion -> Picture
drawRegion r = 
  regionToRGN r $ \ rgn ->
  region rgn

regionToRGN :: MyRegion -> (Region -> Picture) -> Picture

regionToRGN Empty c           = mkEmpty c

regionToRGN (Shape s) c      = shapeToRGN s c

regionToRGN (r1 `Union` r2) c =
  regionToRGN r1     $ \ rgn1 ->
  regionToRGN r2     $ \ rgn2 ->
  orRegion rgn1 rgn2 $ \ rgn ->
  c rgn

regionToRGN (r1 `Intersect` r2) c =
  regionToRGN r1      $ \ rgn1 ->
  regionToRGN r2      $ \ rgn2 ->
  andRegion rgn1 rgn2 $ \ rgn ->
  c rgn

data Shape 
  = Rect    Point Point
  | Ellipse Point Point
  | Polygon [Point]

shapeToRGN :: Shape -> (Region -> Picture) -> Picture
shapeToRGN (Rect    p1 p2) = mkRectangle p1 p2
shapeToRGN (Ellipse p1 p2) = mkEllipse   p1 p2
shapeToRGN (Polygon ps)    = mkPolygon   ps

----------------------------------------------------------------
-- End
----------------------------------------------------------------