hgl-example-0.0.2: src/GraphicDemo.hs

module GraphicDemo where

import Graphics.HGL.Units (Time, Point, Size, )
import Graphics.HGL.Draw.Monad (Graphic, )
import Graphics.HGL.Utils
import Graphics.HGL.Draw.Pen
import Graphics.HGL.Draw.Text
import Graphics.HGL.Draw.Picture
import Graphics.HGL.Window
import Graphics.HGL.Run

import Control.Exception (bracket, )

import Prelude hiding ((^), )
import qualified Prelude as P


-- see HTam.Useful
(^) :: Num a => a -> Int -> a
(^) = (P.^)


aufTasteWarten :: IO ()
aufTasteWarten =
   runWindow "graphic demo" (400,300) getKey

test :: Graphic -> IO ()
test graphic =
   runWindow "graphic demo" (500,500) (\w -> setGraphic w graphic >> getKey w)

testText :: IO ()
testText =
   test (text (10,10) "test")

runWindowEx ::
   Title ->
   Maybe Point ->
   Size ->
   RedrawMode ->
   Maybe Time ->
   (Window -> IO ()) ->
   IO ()
runWindowEx title position size drawMode timerUnit act =
   runGraphics $
      bracket
         (openWindowEx title position size drawMode timerUnit)
         closeWindow
         act

testAnim :: Time -> [Graphic] -> IO ()
testAnim dur frames =
   runWindowEx "graphic demo" Nothing (500,500) DoubleBuffered (Just dur) $
      \w ->
         -- w <- openWindow "graphic demo" (500,500)
         -- setGraphic w (text (10,10) "test")
         mapM_ (\frame -> setGraphic w frame >> getWindowTick w) frames
         -- getKey w

textAnim :: IO ()
textAnim =
   testAnim 20 (map (\pos -> text (pos,2*pos) "test") [0..])

dreieck :: IO ()
dreieck =
   test (polyline [(0,0),(100,100),(200,0)])

siebzehneck :: IO ()
siebzehneck =
   test (polygon (map (\i ->
       let angle = (fromInteger i /17*2*pi)::Double
       in  (250+round(200*cos angle),250+round(200*sin angle))) [0..16]))

spirale :: IO ()
spirale =
   test (polyline (map (\i ->
       let angle = (fromInteger i / 200 * 2*pi)::Double
       in  (250+round(10*angle*cos angle),250+round(10*angle*sin angle))) [0..1000]))

spiralenpunkte :: Double -> [(Int,Int)]
spiralenpunkte anfang =
   map (\i ->
         let angle = (fromInteger i / 20 * 2*pi)::Double
         in  (250+round(10*angle*cos (anfang+angle)),
              250+round(10*angle*sin (anfang+angle)))) [0..100]

spiralenpunkteGleichmaessig :: Double -> [(Int,Int)]
spiralenpunkteGleichmaessig anfang =
   let angleList = take 100 $
          iterate (\angle -> angle + 9 * recip (25 + angle)) 0
   in  map (\angle ->
             (250+round(10*angle*cos(anfang+angle)),
              250+round(10*angle*sin(anfang+angle)))) angleList

doppelSpirale :: IO ()
doppelSpirale =
   test (overGraphics
            [polyline (spiralenpunkte 0),
             polyline (spiralenpunkte (4*pi/3)),
             polyline (spiralenpunkte (2*pi/3))])

spiraleAnim :: IO ()
spiraleAnim =
   testAnim 20
      (map (\phase -> polyline (spiralenpunkteGleichmaessig phase))
           [0,(-0.1)..])

lissajous :: IO ()
lissajous =
   test (polyline (map (\i ->
      let angle = (fromInteger i / 200 * 2*pi)::Double
      in  (250+round(200*sin (2*angle)),
           250+round(200*sin angle))) [0..200]))

{- Warten mit Standard-UNIX-Funktionen geht irgendwie nicht.
lissajousAnim =
   withWindow "graphic demo" (500,500) (\w -> mapM_ (\phase -> runGraphics (setGraphic w (polyline (map(\i -> let angle = (fromInteger i / 50 * 2*pi)::Double in (250+round(200*sin (angle)),250+round(200*sin (2*angle+phase)))) [0..50])) >> usleep 20000)) [0,0.1..])
-}

lissajousAnim :: IO ()
lissajousAnim =
   testAnim 20
     (map (\phase -> polyline
             (map(\i ->
               let angle = (fromInteger i / 100 * 2*pi)::Double
               in  (250+round(200*sin (2.3*(angle+phase)+phase)),
                    250+round(200*sin (3*(angle+phase))))) [0..100]))
          [0,0.05..])


kreispunkte :: (Double, Double) -> Double -> Int -> Double -> Double
   -> [(Double, Double)]
kreispunkte (mx,my) radius n start inc =
   map (\angle ->
           let x = mx + radius * cos angle
               y = my + radius * sin angle
           in  (x, y))
       (take n (iterate (inc+) start))

roundPoint :: (Double, Double) -> Point
roundPoint (x,y) = (round x, round y)


sternAnim :: IO ()
sternAnim =
   runWindowEx "graphic demo" Nothing (500,500) DoubleBuffered (Just 33) $
      \w -> do
         let rgbs = map (\green -> RGB 255 green 0) [0,5..255]
         pens <- sequence (zipWith (createPen Solid) (map (flip div 5) [0..]) rgbs)
         mapM_ (\phase -> setGraphic w (
            let size = (1 + sin (3*phase)) / 2
            in  selectPen (pens !! round (size * fromIntegral (length pens - 1)))
                >> polyline (map roundPoint
                     (kreispunkte (250,250) (40 + 160*size) 10 phase (8/9*pi))))
            >> getWindowTick w) [0,0.03..]


sternenkreisAnim :: IO ()
sternenkreisAnim =
   let stern phase m =
          polygon (map roundPoint (kreispunkte m 50 6 phase (2*2*pi/5)))
   in  testAnim 20
         (map (\phase -> overGraphics
                 (map (stern (-phase))
                      (kreispunkte (250, 250) 150 7 phase (2*pi/7))))
              [0,0.02..])