hgl-example-0.0.1: src/GraphicDemo.hs
module GraphicDemo where
{-
hugs GraphicDemo
-}
{-
hugs
:load Graphics.HGL.Utils
:browse Graphics.HGL.Utils
-}
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 System.Random (RandomGen, randomRs, mkStdGen, )
import Data.Array (listArray, bounds, (!), )
import Control.Exception (bracket, )
import qualified Numerics.ZeroFinder.Newton as Newton
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..])
polygonMove :: Num a => (a,a) -> [(a,a)] -> [(a,a)]
polygonMove (dx,dy) = map (\(x,y) -> (x+dx,y+dy))
polygonTurn :: Floating a => a -> [(a,a)] -> [(a,a)]
polygonTurn angle =
polygonOrtho (cos angle, sin angle)
polygonOrtho :: Num a => (a,a) -> [(a,a)] -> [(a,a)]
polygonOrtho (rx,ry) =
map (\(x,y) -> (x*rx-y*ry,x*ry+y*rx))
norm :: Floating a => (a,a) -> a
norm (x,y) = sqrt (x^2+y^2)
normalize :: Floating a => (a,a) -> (a,a)
normalize (x,y) =
let n = norm (x,y)
in (x/n, y/n)
lok :: Num a => [(a,a)]
lok =
[( 0, 0), ( 0,130), ( 80,130), ( 80,70),
( 20,70), ( 20,110), ( 60,110), ( 60,70),
(170,70), (165,120), (185,120), (180,70),
(190,70), (200, 0), ( 0, 0)]
lok' :: Num a => [(a,a)]
lok' =
[( 0, 0), ( 0,130), ( 80,130), ( 80,70),
( 20,70), ( 20,110), ( 60,110), ( 60,70),
(170,70), (165,120), (185,120), (180,70),
(190,70), (200, 0),
(155, 0), (150, 10), (145, 0),
( 55, 0), ( 50, 10), ( 45, 0),
( 0, 0)]
flipY :: Num a => [(a,a)] -> [(a,a)]
flipY = map (\(dx,dy) -> (dx,-dy))
wagenAnim :: IO ()
wagenAnim =
testAnim 20
(map (\zeit ->
let (pos, dreh) = properFraction (zeit::Double)
angle = dreh * pi/2
laenge = 50
dx = round (laenge * sin angle)
dy = round (laenge * cos angle)
dx2 = round (laenge/sqrt 2 * sin (angle-pi/4))
dy2 = round (laenge/sqrt 2 * cos (angle-pi/4))
x = pos * round laenge
y = 300
quadrat (mx,my) =
polyline [(mx, my), (mx+dx, my-dy),
(mx+dx-dy, my-dx-dy), (mx-dy, my-dx),
(mx, my)]
wanne m =
polygon (polygonMove m (flipY lok))
in overGraphics [quadrat (x-100,y), quadrat (x,y),
wanne (x + dx2-150, y - dy2)])
[0,0.025..])
circle, circleFill, circleFill' :: Int -> Point -> Graphic
circle = circlePoly 20 0
circleFill' r (x,y) = arc (x-r,y-r) (x+r,y+r) 0 270
circleFill r (x,y) = ellipse (x-r,y-r) (x+r,y+r)
circlePoly :: Int -> Double -> Int -> Point -> Graphic
circlePoly n angle r (x,y) =
polyline (map roundPoint
(kreispunkte (fromIntegral x, fromIntegral y)
(fromIntegral r) (n+1) angle (2*pi/fromIntegral n)))
wheel :: Double -> Double -> (Double, Double) -> Graphic
wheel radius angle (xd,yd) =
let dx = round (radius * sin angle)
dy = round (radius * cos angle)
x = round xd
y = round yd
in overGraphics [circlePoly 20 angle (round radius) (x,y),
polyline [(x-dx,y+dy),(x+dx,y-dy)],
polyline [(x-dy,y-dx),(x+dy,y+dx)]]
holperAnim0 :: IO ()
holperAnim0 =
testAnim 5
(map (\zeit ->
let radius = 25
mount = 10
wheelDist = 100
angle = zeit * pi/2
mx = mount * sin angle
my = mount * cos angle
x = angle * radius
y = 300
wanne m = polygon (polygonMove m (flipY lok))
in overGraphics [wheel radius angle (x,y),
wheel radius angle (x-wheelDist,y),
wanne (round (x+mx - 150), round (y-my))])
[0,0.025..])
holperAnim1 :: IO ()
holperAnim1 =
testAnim 5
(map (\zeit ->
let radius = 25
mount = 15
angle = zeit * pi/2
mx = mount * sin angle
my = mount * cos angle
x = angle * radius
y = 300
xLW = x+mx-wheelDistX
angleLW = xLW / radius
wheelDist = 100
wheelDistX = sqrt(wheelDist^2 - my^2)
wanne m = polygon (map roundPoint (polygonMove m (flipY
(polygonOrtho (normalize (wheelDistX,my))
(polygonMove (-150,0) lok)))))
in overGraphics [wheel radius angle (x, y),
wheel radius angleLW (xLW,y),
wanne (x+mx, y-my)])
[0,0.025..])
{- Inverse cycloid function. -}
cycloidAngle :: Floating a => a -> a -> a -> a -> (a,a) -> [a]
cycloidAngle t0 radius mount d (x,y) =
let f t = let ct = cos t
st = sin t
xt = radius * t + mount * ct - x
yt = mount * st - y
in (xt^2+yt^2,
2 * (xt * (radius - mount * st) + yt * mount * ct))
in Newton.inverse t0 f (d^2)
propCycloidAngle :: Floating a => a -> a -> (a,a) -> ((a,a), (a,a))
propCycloidAngle radius d (x,y) =
let sq = sqrt (d^2-y^2)
t0 = (x - sq) / radius
t1 = (x + sq) / radius
in ((t0, cycloidAngle (2*t0) radius 0 d (x,y) !! 10),
(t1, cycloidAngle (2*t1) radius 0 d (x,y) !! 10))
holperAnim :: IO ()
holperAnim =
testAnim 5
(map (\zeit ->
let radiusRW = 25
radiusLW = 35
mountRW = 15
mountLW = 20
yRW = 300
yLW = yRW-radiusLW+radiusRW
angleRW = zeit * pi/2
dxRW = mountRW * cos angleRW
dyRW = mountRW * sin angleRW
dxLW = mountLW * cos angleLW
dyLW = mountLW * sin angleLW
wheelDist = 100
angleLW =
cycloidAngle
((xRW-wheelDist)/radiusLW) radiusLW mountLW
wheelDist (xRW+dxRW,dyRW+yRW-yLW) !! 10
xLW = angleLW * radiusLW
xRW = angleRW * radiusRW
wanne m = polygon (map roundPoint (polygonMove m (flipY
(polygonOrtho
(normalize (xRW+dxRW-(xLW+dxLW),
-(yRW+dyRW)+(yLW+dyLW)))
(polygonMove (-150,0) lok)))))
in overGraphics [wheel radiusRW angleRW (xRW,yRW),
wheel radiusLW angleLW (xLW,yLW),
wanne (xRW+dxRW, yRW+dyRW)])
[0,0.025..])
{- |
probabilistic Sierpinski triangle
See Computer Graphics I lecture at the university of Halle.
-}
sierpinskiPoints :: (Fractional a, RandomGen g) =>
g -> ((a,a), (a,a), (a,a)) -> [(a,a)]
sierpinskiPoints g (t0,t1,t2) =
let vertices = listArray (0,2::Int) [t0,t1,t2]
in scanl1 (\(xt,yt) (xk,yk) -> ((xt+xk)/2, (yt+yk)/2))
(map (vertices!) (randomRs (bounds vertices) g))
sierpinski :: IO ()
sierpinski =
let ps = ((0, 0), (1, 0), (0.5, sqrt 3 / 2))
size = 1000
toInt :: Double -> Int
toInt x = round (x * fromIntegral size)
setDot p = polyline [p, p]
graphics = map (\(x,y) -> setDot (toInt x, toInt y))
(sierpinskiPoints (mkStdGen 834750) ps)
in runWindow "Sierpinski" (size,size)
(\w -> mapM_ (directDraw w) graphics)