diff --git a/Makefile b/Makefile new file mode 100644 --- /dev/null +++ b/Makefile @@ -0,0 +1,8 @@ +ghci: + ghci +RTS -M64m -c30 -RTS -Wall -i:src src/Main.hs + +demo: + hgl-example rotating-spiral rotating-lissajous stars star-circle `seq -f 'locomotive-%g' 0 3` + +record: + recordmydesktop -x 1 -y 1 --width 500 --height 530 --no-sound diff --git a/demo.readme b/demo.readme new file mode 100644 --- /dev/null +++ b/demo.readme @@ -0,0 +1,30 @@ +Haskell animation demo + +Some small animations using the HGL package +showing rotating spiral, stars and Lissajous curves +and finally some locomotives with strange wheels. + +For installation run +$ cabal install hgl-example-0.0.1 + +You need to have my math utility package installed, +which is so experimental that I didn't upload it to Hackage, so far. + +$ darcs get http://darcs.haskell.org/htam/ +$ (cd htam; cabal install) + + +The demo is started by + +$ hgl-example rotating-spiral rotating-lissajous stars star-circle `seq -f 'locomotive-%g' 0 3` + +See also the Makefile. + +For more information on the Haskell programming language, +see http://www.haskell.org/ . + + + +Tags: Haskell, Functional Programming, Animation + +Kategorie: Film und Animation diff --git a/hgl-example.cabal b/hgl-example.cabal --- a/hgl-example.cabal +++ b/hgl-example.cabal @@ -1,5 +1,5 @@ Name: hgl-example -Version: 0.0.1 +Version: 0.0.2 License: GPL License-File: LICENSE Author: Henning Thielemann @@ -24,16 +24,22 @@ Cabal-Version: >=1.2 Build-Type: Simple +Extra-Source-Files: + Makefile + demo.readme + Executable hgl-example Build-Depends: HTam >=0.0.2 && <0.1, HGL >=3.2 && <3.3, + utility-ht >=0.0.1 && <0.1, random >=1.0 && <1.1, - array >=0.1 && <0.3, - base >= 3 + array >=0.1 && <0.6, + base >= 3 && <5 GHC-Options: -Wall Hs-Source-Dirs: src Main-Is: Main.hs Other-Modules: + Sierpinski GraphicDemo diff --git a/src/GraphicDemo.hs b/src/GraphicDemo.hs --- a/src/GraphicDemo.hs +++ b/src/GraphicDemo.hs @@ -1,18 +1,5 @@ - 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 @@ -22,13 +9,8 @@ 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 @@ -181,207 +163,3 @@ (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) diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -1,6 +1,19 @@ +{- + hugs -P:src src/Main.hs +-} + +{- + hugs + + :load Graphics.HGL.Utils + + :browse Graphics.HGL.Utils +-} module Main where -import GraphicDemo as G +import qualified GraphicDemo as G +import qualified Sierpinski as S +import qualified Locomotive as L import System.Environment (getArgs, ) import System.Exit (exitWith, ExitCode(..), ) @@ -9,21 +22,21 @@ demos :: [(String, IO ())] demos = - ("text", textAnim) : - ("triangle", dreieck) : - ("17angle", siebzehneck) : - ("spiral", spirale) : - ("double-spiral", doppelSpirale) : - ("rotating-spiral", spiraleAnim) : - ("lissajous", lissajous) : - ("rotating-lissajous", lissajousAnim) : - ("rotating-star", sternAnim) : - ("star-circle", sternenkreisAnim) : - ("locomotive-0", wagenAnim) : - ("locomotive-1", holperAnim0) : - ("locomotive-2", holperAnim1) : - ("locomotive-3", holperAnim) : - ("sierpinski", sierpinski) : + ("text", G.textAnim) : + ("triangle", G.dreieck) : + ("17angle", G.siebzehneck) : + ("spiral", G.spirale) : + ("double-spiral", G.doppelSpirale) : + ("rotating-spiral", G.spiraleAnim) : + ("lissajous", G.lissajous) : + ("rotating-lissajous", G.lissajousAnim) : + ("rotating-star", G.sternAnim) : + ("star-circle", G.sternenkreisAnim) : + ("locomotive-0", L.squareWheelAnim) : + ("locomotive-1", L.acentricAnim) : + ("locomotive-2", L.asymmetricAnim) : + ("locomotive-3", L.bigSmallAnim) : + ("sierpinski", S.demo) : [] diff --git a/src/Sierpinski.hs b/src/Sierpinski.hs new file mode 100644 --- /dev/null +++ b/src/Sierpinski.hs @@ -0,0 +1,36 @@ +{- | +probabilistic Sierpinski triangle + +See Computer Graphics I lecture at the university of Halle. +-} +module Sierpinski (demo, ) where + +import Graphics.HGL.Utils (runWindow, ) +import Graphics.HGL.Draw.Picture (polyline, ) +import Graphics.HGL.Window (directDraw, ) + +import System.Random (RandomGen, randomRs, mkStdGen, ) +import Data.Array (listArray, bounds, (!), ) + +import Data.Tuple.HT (mapPair, ) + + +points :: (Fractional a, RandomGen g) => + g -> ((a,a), (a,a), (a,a)) -> [(a,a)] +points 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)) + +demo :: IO () +demo = + let size = 1000 + toInt :: Double -> Int + toInt x = round (x * fromIntegral size) + setDot p = polyline [p, p] + graphics = + map (setDot . mapPair (toInt, toInt)) $ + points (mkStdGen 834750) $ + ((0, 0), (1, 0), (0.5, sqrt 3 / 2)) + in runWindow "Sierpinski" (size,size) + (\w -> mapM_ (directDraw w) graphics)