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)