Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Deleted extraneous files

  • Loading branch information...
commit 293fd35fced05aef785b0caf576de904c752a420 1 parent 8e8bf56
@hybridthesis authored
View
82 Draw.hs
@@ -1,82 +0,0 @@
-module Draw (inchToPixel, pixelToInch, intToFloat,
- xWin, yWin, trans, shapeToGraphic, spaceClose
- ) where
-
- import Shape
- import Graphics.SOE
-
- xWin, yWin :: Int
- xWin = 600
- yWin = 500
-
- xWin2, yWin2 :: Int
- xWin2 = xWin `div` 2
- yWin2 = yWin `div` 2
-
- inchToPixel :: Float -> Int
- inchToPixel x = round (100 * x)
-
- pixelToInch :: Int -> Float
- pixelToInch n = intToFloat n/100
-
- intToFloat :: Int -> Float
- intToFloat n = fromInteger (toInteger n)
-
- trans :: Vertex -> Point
- trans (x, y) = (xWin2 + inchToPixel x,
- yWin2 - inchToPixel y)
-
- transList :: [Vertex] -> [Point]
- transList [] = []
- transList (v1:vs) = trans v1 : transList vs
-
- shapeToGraphic :: Shape -> Graphic
- shapeToGraphic (Rectangle s1 s2)
- = let s12 = s1/2
- s22 = s2/2
- in polygon (transList
- [(-s12, -s22), (-s12, s22), (s12, s22), (s12, -s22)])
- shapeToGraphic (Polygon vts)
- = polygon (transList vts)
- shapeToGraphic (Ellipse r1 r2)
- = ellipse (trans (-r1, -r2)) (trans (r1, r2))
- shapeToGraphic (RtTriangle s1 s2)
- = polygon (transList [(0,0),(s1,0), (0,s2)])
-
-
-{- -- Declaring the shape types with their respective geometry -}
--- sh1, sh2, sh3, sh4 :: Shape
--- sh1 = Rectangle 3 2
--- sh2 = Ellipse 1 1.5
--- sh3 = RtTriangle 3 2
--- sh4 = Polygon [(-2.5, 2.5), (-1.5,2.0), (-1.1,0.2), (-1.7,-1.0), (-3.0,0)]
---
-{- --Declaring the shapes colors -}
--- shs :: ColoredShapes
--- shs = [(Red, sh1), (Blue, sh2), (Yellow, sh3), (Magenta, sh4)]
-
- type ColoredShapes = [(Color, Shape)]
-
- conCircles = map circle [2.4,2.1..0.3]
-
- coloredCircles :: ColoredShapes
- coloredCircles =
- zip [Black, Blue, Green, Cyan, Red, Magenta, Yellow, White]
- conCircles
-
- drawShapes :: Window -> ColoredShapes -> IO ()
- drawShapes w css
- = sequence_ (map aux css)
- where aux (c,s) = drawInWindow w $ withColor c $ shapeToGraphic s
-
- spaceClose :: Window -> IO ()
- spaceClose w
- = do k <- getKey w
- if k == ' ' then closeWindow w
- else spaceClose w
- main0
- = runGraphics (
- do w <- openWindow "Drawing" (xWin, yWin)
- drawShapes w coloredCircles
- spaceClose w)
-
View
89 Fractals.hs
@@ -1,89 +0,0 @@
-module Main where
-import SOE
-
-
-spaceClose :: Window -> IO ()
-spaceClose w
- = do k <- getKey w
- if k ==' ' then closeWindow w
- else spaceClose w
-
-
---Sierpinski's Triangle
--- -- {{
-
-fillTri :: Window -> Int -> Int -> Int -> IO ()
-fillTri w x y size
- = drawInWindow w (withColor Blue
- (polygon [(x, y), (x + size, y), (x, y - size), (x, y)]))
-
-
-sierpinskiTri :: Window -> Int -> Int -> Int -> IO ()
-sierpinskiTri w x y size
- = if size <= minSize
- then fillTri w x y size
- else let size2 = size `div` 2
- in do sierpinskiTri w x y size2
- sierpinskiTri w x (y - size2) size2
- sierpinskiTri w (x + size2) y size2
-
-main1
- = runGraphics (
- do w <- openWindow "S Tri" (400, 450)
- sierpinskiTri w 50 400 300
- spaceClose w
- )
--- }}
-
--- Snowflake fractal
--- {{
-
-
-minSize :: Int
-minSize = 8
-
-mulcos30 :: Int -> Int
-mulcos30 n = n * 86603 `div` 100000
-
-fillSnowFlake :: Window -> Int -> Int -> Int -> IO ()
-fillSnowFlake w x y size
--- First you draw the upside down equilateral
- = do drawInWindow w (withColor Blue
- (polygon [(x + size `div` 2, y), --Bottom
- (x, y - (mulcos30 size)), --Upper left
- (x + size, y - (mulcos30 size)), --Upper right
- (x + size `div` 2, y)]))
---Now draw the rightside up version
- drawInWindow w (withColor Blue
- (polygon [(x, y - (mulcos30 (size `div` 3))), --Bottom left
- (x + size `div` 2, y - 4 * (mulcos30 (size `div` 3))), --Tip
- (x + size, y - (mulcos30 (size `div` 3))), --Bottom Right
- (x, y - (mulcos30 (size `div` 3))) ] ))
-
-snowFlakeFractal :: Window -> Int -> Int -> Int -> IO ()
-snowFlakeFractal w x y size
- = do if size <= minSize
- then fillSnowFlake w x y size
- else let size2 = size `div` 3
- y_offset = (mulcos30 size `div` 9)
- x_center = x + size2
- x_left = x
- x_right = x + 2 * size2
- y_top = y - 4 * (mulcos30 size2) + 4 * y_offset
- y_second = y - (mulcos30 size) + 3 * y_offset
- y_third = y - (mulcos30 size2) + y_offset
- y_bottom = y
- in do fillSnowFlake w x y size
- snowFlakeFractal w x_center y_top size2 --Top
- snowFlakeFractal w x_left y_second size2 --TopLeft
- snowFlakeFractal w x_right y_second size2 --TopRight
- snowFlakeFractal w x_left y_third size2 --BottomLeft
- snowFlakeFractal w x_right y_third size2 --BottomRight
- snowFlakeFractal w x_center y_bottom size2 --Bottom
-
-main0
- = runGraphics (
- do w <- openWindow "S Tri" (800, 900)
- snowFlakeFractal w 100 800 600
- spaceClose w
- )
View
BIN  Main
Binary file not shown
View
BIN  Main.hi
Binary file not shown
View
7 Main.hs
@@ -1,7 +0,0 @@
-import SOE
-main
- = runGraphics $
- do w <- openWindow "My First Graphics Program" (300, 300)
- drawInWindow w (text (100, 200) "HelloGraphicsWorld")
- k <- getKey w
- closeWindow w
View
BIN  Main.o
Binary file not shown
View
16 Perimeter.hs
@@ -1,16 +0,0 @@
-module Perimeter (perimeter,
- module Shape
- ) where
- import Shape
-
-
- perimeter :: Shape -> Float
- perimeter (Rectangle s1 s2) = 2 + s1 * s2
- perimeter (RtTriangle s1 s2) = s1 + s2 + sqrt (s1^2 + s2^2)
- perimeter (Polygon vs) = foldl (+) 0 $ sides vs
-
- sides :: [Vertex] -> [Side]
- sides [] = []
- sides (v:vs) = aux v vs
- where aux v1 (v2:vs') = distBetween v1 v2:aux v2 vs'
- aux vn [] = distBetween vn v : []
View
BIN  SOE.hi
Binary file not shown
View
550 SOE.hs
@@ -1,550 +0,0 @@
-module SOE (
- runGraphics,
- Title,
- Size,
- Window,
- openWindow,
- getWindowSize,
- clearWindow,
- drawInWindow,
- drawInWindowNow,
- setGraphic,
- closeWindow,
- openWindowEx,
- RedrawMode,
- drawGraphic,
- drawBufferedGraphic,
- Graphic,
- emptyGraphic,
- overGraphic ,
- overGraphics,
- Color (..),
- withColor,
- text,
- Point,
- ellipse,
- shearEllipse,
- line,
- polygon,
- polyline,
- polyBezier,
- Angle,
- arc,
- Region,
- createRectangle,
- createEllipse,
- createPolygon,
- andRegion,
- orRegion,
- xorRegion,
- diffRegion,
- drawRegion,
- getKey,
- getLBP,
- getRBP,
- Event (..),
- maybeGetWindowEvent,
- getWindowEvent,
- Word32,
- timeGetTime,
- word32ToInt
- ) where
-
-import Data.Ix (Ix)
-import Data.Word (Word32)
-import Control.Concurrent
-import qualified System.Time
-import qualified Graphics.UI.GLFW as GLFW
-import qualified Graphics.Rendering.OpenGL as GL
-import Graphics.Rendering.OpenGL (($=), GLfloat)
-import System.IO.Unsafe
-
-
--------------------
--- Window Functions
--------------------
-
-runGraphics :: IO () -> IO ()
-runGraphics main = main
-
-type Title = String
-type Size = (Int, Int)
-
-data Window = Window {
- graphicVar :: MVar (Graphic, Bool), -- boolean to remember if it's dirty
- eventsChan :: Chan Event
-}
-
--- Graphic is just a wrapper for OpenGL IO
-newtype Graphic = Graphic (IO ())
-
-initialized, opened :: MVar Bool
-initialized = unsafePerformIO (newMVar False)
-opened = unsafePerformIO (newMVar False)
-
-initialize = do
- init <- readMVar initialized
- if init then return ()
- else do
- GLFW.initialize
- modifyMVar_ initialized (\_ -> return True)
- return ()
-
-openWindow :: Title -> Size -> IO Window
-openWindow title size =
- openWindowEx title Nothing (Just size) drawBufferedGraphic
-
--- pos is always ignored due to GLFW
-openWindowEx :: Title -> Maybe Point -> Maybe Size -> RedrawMode -> IO Window
-openWindowEx title position size (RedrawMode useDoubleBuffer) = do
- let siz = maybe (GL.Size 400 300) fromSize size
- initialize
- graphicVar <- newMVar (emptyGraphic, False)
- eventsChan <- newChan
- GLFW.openWindow siz [GLFW.DisplayStencilBits 8, GLFW.DisplayAlphaBits 8] GLFW.Window
- GLFW.windowTitle $= title
- modifyMVar_ opened (\_ -> return True)
- GL.shadeModel $= GL.Smooth
- -- enable antialiasing
- GL.lineSmooth $= GL.Enabled
- GL.blend $= GL.Enabled
- GL.blendFunc $= (GL.SrcAlpha, GL.OneMinusSrcAlpha)
- GL.lineWidth $= 1.5
-
- -- this will hang on Windows
- -- let updateWindow = readMVar graphicVar >>= (\(Graphic g) -> g >> GLFW.swapBuffers)
- -- GLFW.windowRefreshCallback $= updateWindow
-
- let motionCallback (GL.Position x y) =
- writeChan eventsChan MouseMove { pt = (fromIntegral x, fromIntegral y) }
- GLFW.mousePosCallback $= motionCallback
-
- GLFW.charCallback $= (\char state -> do
- writeChan eventsChan (Key {
- char = char,
- isDown = (state == GLFW.Press) }))
-
- GLFW.mouseButtonCallback $= (\but state -> do
- GL.Position x y <- GL.get GLFW.mousePos
- writeChan eventsChan (Button {
- pt = (fromIntegral x, fromIntegral y),
- isLeft = (but == GLFW.ButtonLeft),
- isDown = (state == GLFW.Press) }))
-
- GLFW.windowSizeCallback $= writeChan eventsChan . Resize
- GLFW.windowRefreshCallback $= writeChan eventsChan Refresh
- GLFW.windowCloseCallback $= closeWindow_ eventsChan
-
- return Window {
- graphicVar = graphicVar,
- eventsChan = eventsChan
- }
-
-getWindowSize :: Window -> IO Size
-getWindowSize win = do
- (GL.Size x y) <- GL.get GLFW.windowSize
- return (fromIntegral x, fromIntegral y)
-
-clearWindow :: Window -> IO ()
-clearWindow win = setGraphic win (Graphic (return ()))
-
-drawInWindow :: Window -> Graphic -> IO ()
-drawInWindow win graphic =
- modifyMVar_ (graphicVar win) (\ (g, _) ->
- return (overGraphic graphic g, True))
-
--- if window is marked as dirty, mark it clean, draw and swap buffer;
--- otherwise do nothing.
-updateWindowIfDirty win = do
- io <- modifyMVar (graphicVar win) (\ (g@(Graphic io), dirty) -> do
- return ((g, False), if dirty then io >> GLFW.swapBuffers
- else return ()))
- io
-
-drawInWindowNow :: Window -> Graphic -> IO ()
-drawInWindowNow win graphic = do
- drawInWindow win graphic
- updateWindowIfDirty win
-
--- setGraphic set the given Graphic over empty (black) background for
--- display in current Window.
-setGraphic :: Window -> Graphic -> IO ()
-setGraphic win graphic = do
- modifyMVar_ (graphicVar win) (\_ ->
- return (overGraphic graphic emptyGraphic, True))
-
-closeWindow :: Window -> IO ()
-closeWindow win = closeWindow_ (eventsChan win)
-
-closeWindow_ chan = do
- writeChan chan Closed
- modifyMVar_ opened (\_ -> return False)
- GLFW.closeWindow
- GLFW.pollEvents
-
---------------------
--- Drawing Functions
---------------------
-
-newtype RedrawMode = RedrawMode Bool
-
-drawGraphic :: RedrawMode
-drawGraphic = RedrawMode False
-
-drawBufferedGraphic :: RedrawMode
-drawBufferedGraphic = RedrawMode True
-
-data Color = Black
- | Blue
- | Green
- | Cyan
- | Red
- | Magenta
- | Yellow
- | White
- deriving (Eq, Ord, Bounded, Enum, Ix, Show, Read)
-
-type Angle = GLfloat
-
-emptyGraphic :: Graphic
-emptyGraphic = Graphic $ do
- GL.clearColor $= GL.Color4 0 0 0 0
- GL.clear [GL.ColorBuffer, GL.StencilBuffer]
-
-overGraphic :: Graphic -> Graphic -> Graphic
-overGraphic (Graphic over) (Graphic base) = Graphic (base >> over)
-
-overGraphics :: [Graphic] -> Graphic
-overGraphics = foldl1 overGraphic
-
-colorToRGB :: Color -> GL.Color3 GLfloat
-colorToRGB Black = GL.Color3 0 0 0
-colorToRGB Blue = GL.Color3 0 0 1
-colorToRGB Green = GL.Color3 0 1 0
-colorToRGB Cyan = GL.Color3 0 1 1
-colorToRGB Red = GL.Color3 1 0 0
-colorToRGB Magenta = GL.Color3 1 0 1
-colorToRGB Yellow = GL.Color3 1 1 0
-colorToRGB White = GL.Color3 1 1 1
-
-withColor :: Color -> Graphic -> Graphic
-withColor color (Graphic g) = Graphic (GL.color (colorToRGB color) >> g)
-
-text :: Point -> String -> Graphic
-text (x,y) str = Graphic $ GL.preservingMatrix $ do
- GL.translate (GL.Vector3 (fromIntegral x) (fromIntegral y + 16) (0::GLfloat))
- GL.scale 1 (-1) (1::GLfloat)
- GLFW.renderString GLFW.Fixed8x16 str
-
-type Point = (Int, Int)
-
-ellipse :: Point -> Point -> Graphic
-ellipse pt1 pt2 = Graphic $ GL.preservingMatrix $ do
- let (x, y, width, height) = normaliseBounds pt1 pt2
- (r1, r2) = (width / 2, height / 2)
- GL.translate (GL.Vector3 (x + r1) (y + r2) 0)
- GL.renderPrimitive GL.Polygon (circle r1 r2 0 (2 * pi) (20 / (r1 + r2)))
-
-shearEllipse :: Point -> Point -> Point -> Graphic
-shearEllipse p0 p1 p2 = Graphic $
- let (x0,y0) = fromPoint p0
- (x1,y1, w, h) = normaliseBounds p1 p2
- (x2,y2) = (x1 + w, y1 + h)
- x = (x1 + x2) / 2 -- centre of parallelogram
- y = (y1 + y2) / 2
- dx1 = (x1 - x0) / 2 -- distance to corners from centre
- dy1 = (y1 - y0) / 2
- dx2 = (x2 - x0) / 2
- dy2 = (y2 - y0) / 2
- pts = [ (x + c*dx1 + s*dx2, y + c*dy1 + s*dy2)
- | (c,s) <- cos'n'sins ]
- cos'n'sins = [ (cos a, sin a) | a <- segment 0 (2 * pi) (40 / (w + h))]
- in GL.renderPrimitive GL.Polygon $
- mapM_ (\ (x, y) -> GL.vertex (vertex3 x y 0)) pts
-
-line :: Point -> Point -> Graphic
-line (x1, y1) (x2, y2) = Graphic $
- GL.renderPrimitive GL.LineStrip (do
- GL.vertex (vertex3 (fromIntegral x1) (fromIntegral y1) 0)
- GL.vertex (vertex3 (fromIntegral x2) (fromIntegral y2) 0))
-
-polygon :: [Point] -> Graphic
-polygon ps = Graphic $ do
- GL.renderPrimitive GL.Polygon (foldr1 (>>) (map
- (\ (x, y) -> GL.vertex (vertex3 (fromIntegral x) (fromIntegral y) 0))
- ps))
-
-polyline :: [Point] -> Graphic
-polyline ps = Graphic $
- GL.renderPrimitive GL.LineStrip (foldr1 (>>) (map
- (\ (x, y) -> GL.vertex (vertex3 (fromIntegral x) (fromIntegral y) 0))
- ps))
-
-polyBezier :: [Point] -> Graphic
-polyBezier [] = Graphic $ return ()
-polyBezier ps = polyline (map (bezier ps) (segment 0 1 dt))
- where
- dt = 1 / (lineLength ps / 8)
- lineLength :: [Point] -> GLfloat
- lineLength ((x1,y1):(x2,y2):ps) =
- let dx = x2 - x1
- dy = y2 - y1
- in sqrt (fromIntegral (dx * dx + dy * dy)) + lineLength ((x2,y2):ps)
- lineLength _ = 0
-
-bezier :: [Point] -> GLfloat -> Point
-bezier [(x1,y1)] t = (x1, y1)
-bezier [(x1,y1),(x2,y2)] t = (x1 + truncate (fromIntegral (x2 - x1) * t),
- y1 + truncate (fromIntegral (y2 - y1) * t))
-bezier ps t = bezier (map (\ (p, q) -> bezier [p,q] t) (zip ps (tail ps))) t
-
-arc :: Point -> Point -> Angle -> Angle -> Graphic
-arc pt1 pt2 start extent = Graphic $ do
- let (x, y, width, height) = normaliseBounds pt1 pt2
- (r1, r2) = (width / 2, height / 2)
- GL.translate (GL.Vector3 (x + r1) (y + r2) 0)
- GL.renderPrimitive GL.LineStrip (circle r1 r2
- (-(start + extent) * pi / 180) (-start * pi / 180) (20 / (r1 + r2)))
-
--------------------
--- Region Functions
--------------------
-
-createRectangle :: Point -> Point -> Region
-createRectangle pt1 pt2 =
- let (x,y,width,height) = normaliseBounds' pt1 pt2
- [x0, y0, x1, y1] = map fromIntegral [x, y, x + width, y + height]
- drawing =
- GL.renderPrimitive GL.Quads (do
- GL.vertex (vertex3 x0 y0 0)
- GL.vertex (vertex3 x1 y0 0)
- GL.vertex (vertex3 x1 y1 0)
- GL.vertex (vertex3 x0 y1 0))
- in [[Pos ("R" ++ show (x0,y0,x1,y1), drawing)]]
-
-createEllipse :: Point -> Point -> Region
-createEllipse pt1 pt2 =
- let (x,y,width,height) = normaliseBounds' pt1 pt2
- drawing =
- GL.preservingMatrix $ do
- let (x, y, width, height) = normaliseBounds pt1 pt2
- (r1, r2) = (width / 2, height / 2)
- GL.translate (GL.Vector3 (x + r1) (y + r2) 0)
- GL.renderPrimitive GL.Polygon (circle r1 r2 0 (2 * pi) (20 / (r1 + r2)))
- in [[Pos ("E" ++ show (x, y, width, height), drawing)]]
-
-createPolygon :: [Point] -> Region
-createPolygon [] = [[]]
-createPolygon ps =
- let (minx, maxx, miny, maxy) = (minimum (map fst ps), maximum (map fst ps),
- minimum (map snd ps), maximum (map snd ps))
- drawing = do
- GL.renderPrimitive GL.Polygon (foldr1 (>>) (map
- (\ (x, y) -> GL.vertex (vertex3 (fromIntegral x) (fromIntegral y) 0))
- ps))
- in [[Pos ("P"++show ps, drawing)]]
-
-andRegion, orRegion, xorRegion, diffRegion :: Region -> Region -> Region
-
--- We'll convert region expression into disjuction canonical form
--- so as to make rendering easier using Stencil buffer.
-
-type Region = [Conjuction]
-type Conjuction = [Atom]
-data Atom = Pos Atom' | Neg Atom'
-type Atom' = (String, IO ())
-instance Show Atom where
- show (Pos (s, _)) = "+" ++ s
- show (Neg (s, _)) = "-" ++ s
-
-conjuction :: Region -> Region -> Region
-conjuction xs ys = [ x ++ y | x <- xs, y <- ys ]
-disjuction xs ys = xs ++ ys
-negTerm [] = []
-negTerm xs = foldl1 conjuction (map negA xs)
- where
- negA :: Conjuction -> Region
- negA ys = map negS ys
- negS :: Atom -> Conjuction
- negS (Pos i) = [Neg i]
- negS (Neg i) = [Pos i]
-
-data RegionOp = AND | OR | XOR | DIFF
-
-andRegion = combineRegion AND
-orRegion = combineRegion OR
-xorRegion = combineRegion XOR
-diffRegion = combineRegion DIFF
-
-drawRegion :: Region -> Graphic
-drawRegion term = Graphic drawAux
- where
- drawAux = do
- GL.stencilMask $= 1
- GL.stencilTest $= GL.Enabled
- sequence_ [drawConjuction (posT t) (negT t) | t <- term]
- GL.stencilTest $= GL.Disabled
-
- posT [] = []
- posT (Pos x:xs) = x : posT xs
- posT (_:xs) = posT xs
-
- negT [] = []
- negT (Neg x:xs) = x : negT xs
- negT (_:xs) = negT xs
-
- drawConjuction ps ns = do
- -- render all positive atoms only to stencil buffer
- GL.depthFunc $= Just GL.Never
- GL.stencilMask $= 0xff
- GL.stencilFunc $= (GL.Greater, 0, 0xff)
- -- every pixel rendered increases the value in the stencil buffer by 1
- GL.stencilOp $= (GL.OpIncr, GL.OpIncr, GL.OpZero)
- mapM_ drawIt ps
- -- render all negative atoms to clear the stencil pixel to 0
- GL.stencilOp $= (GL.OpZero, GL.OpZero, GL.OpZero)
- mapM_ drawIt ns
- -- finally render all positive atoms to screen where the stencil pixel
- -- equals (length ps)
- GL.depthFunc $= Just GL.Always
- GL.stencilFunc $= (GL.Equal, fromIntegral $ length ps, 0xff)
- GL.stencilOp $= (GL.OpZero, GL.OpZero, GL.OpZero)
- mapM_ drawIt ps
-
- drawIt (_, io) = io
-
---combineRegion :: Cairo.Operator -> Region -> Region -> Region
-combineRegion operator a b =
- case operator of
- AND -> conjuction a b
- OR -> disjuction a b
- XOR -> disjuction (conjuction (negTerm a) b) (conjuction a (negTerm b))
- DIFF -> conjuction a (negTerm b)
-
----------------------------
--- Event Handling Functions
----------------------------
-
-data Event = Key {
- char :: Char,
- isDown :: Bool
- }
- | Button {
- pt :: Point,
- isLeft :: Bool,
- isDown :: Bool
- }
- | MouseMove {
- pt :: Point
- }
- | Resize GL.Size
- | Refresh
- | Closed
- deriving Show
-
-getWindowEvent :: Window -> IO Event
-getWindowEvent win = do
- event <- maybeGetWindowEvent win
- maybe (getWindowEvent win) return event
-
-maybeGetWindowEvent :: Window -> IO (Maybe Event)
-maybeGetWindowEvent win = do
- updateWindowIfDirty win
- noEvents <- isEmptyChan (eventsChan win)
- if noEvents
- then GLFW.sleep 0.01 >> GLFW.pollEvents >> return Nothing
- else do
- event <- readChan (eventsChan win)
- case event of
- Refresh -> do
- (Graphic io, _) <- readMVar (graphicVar win)
- io
- GLFW.swapBuffers
- maybeGetWindowEvent win
- Resize size@(GL.Size w h) -> do
- GL.viewport $= (GL.Position 0 0, size)
- GL.matrixMode $= GL.Projection
- GL.loadIdentity
- GL.ortho2D 0 (realToFrac w) (realToFrac h) 0
- -- force a refresh, needed for OS X
- writeChan (eventsChan win) Refresh
- maybeGetWindowEvent win
- e -> return (Just e)
-
-getKeyEx :: Window -> Bool -> IO Char
-getKeyEx win down = loop
- where loop = do e <- getWindowEvent win
- case e of
- (Key { char = ch, isDown = d })
- | d == down -> return ch
- Closed -> return '\x0'
- _ -> loop
-
-getKey :: Window -> IO Char
-getKey win = do
- ch <- getKeyEx win True
- if ch == '\x0' then return ch
- else getKeyEx win False
-
-getButton :: Window -> Int -> Bool -> IO Point
-getButton win but down = loop
- where loop = do e <- getWindowEvent win
- case e of
- (Button { pt = pt, isDown = id })
- | id == down -> return pt
- _ -> loop
-
-getLBP :: Window -> IO Point
-getLBP w = getButton w 1 True
-
-getRBP :: Window -> IO Point
-getRBP w = getButton w 2 True
-
--- use GLFW's high resolution timer
-timeGetTime :: IO Word32
-timeGetTime = do
- timeInSec <- GL.get GLFW.time
- return $ round $ timeInSec * 1000
-
-word32ToInt :: Word32 -> Int
-word32ToInt = fromIntegral
-
-----------------------
--- Auxiliary Functions
-----------------------
-
-vertex4 :: GLfloat -> GLfloat -> GLfloat -> GLfloat -> GL.Vertex4 GLfloat
-vertex4 = GL.Vertex4
-
-vertex3 :: GLfloat -> GLfloat -> GLfloat -> GL.Vertex3 GLfloat
-vertex3 = GL.Vertex3
-
-normaliseBounds :: Point -> Point -> (GLfloat,GLfloat,GLfloat,GLfloat)
-normaliseBounds (x1,y1) (x2,y2) = (x, y, width, height)
- where x = fromIntegral $ min x1 x2
- y = fromIntegral $ min y1 y2
- width = fromIntegral $ abs $ x1 - x2
- height = fromIntegral $ abs $ y1 - y2
-
-normaliseBounds' :: Point -> Point -> (Int,Int,Int,Int)
-normaliseBounds' (x1,y1) (x2,y2) = (x, y, width, height)
- where x = min x1 x2
- y = min y1 y2
- width = abs $ x1 - x2
- height = abs $ y1 - y2
-
-fromPoint :: Point -> (GLfloat, GLfloat)
-fromPoint (x1, x2) = (fromIntegral x1, fromIntegral x2)
-
-fromSize (x, y) = GL.Size (fromIntegral x) (fromIntegral y)
-
--- we add 20 pixels to the y position to leave space for window title bar
-fromPosition (x, y) = GL.Position (fromIntegral x) (20 + fromIntegral y)
-
-circle r1 r2 start stop step =
- let vs = [ (r1 * cos i, r2 * sin i) | i <- segment start stop step ]
- in mapM_ (\(x, y) -> GL.vertex (vertex3 x y 0)) vs
-
-segment start stop step = ts start
- where ts i = if i >= stop then [stop] else (i : ts (i + step))
-
View
BIN  SOE.o
Binary file not shown
View
42 Shape.hs
@@ -1,42 +0,0 @@
-module Shape (Shape(Rectangle, Ellipse, RtTriangle, Polygon),
- Radius, Side, Vertex,
- area, triArea, distBetween,
- circle, square,
- )
- where
-
- data Shape = Rectangle Side Side
- | Ellipse Radius Radius
- | RtTriangle Side Side
- | Polygon [Vertex]
- deriving Show
-
- type Radius = Float
- type Side = Float
- type Vertex = (Float, Float)
-
- circle :: Radius -> Shape
- circle r = Ellipse r r
-
- square :: Side -> Shape
- square s = Rectangle s s
-
- area :: Shape -> Float
- area (Rectangle s1 s2) = s1 * s2
- area (Ellipse r1 r2) = r1 * r2 * pi
- area (RtTriangle s1 s2) = s1 * s2 / 2
- area (Polygon (v1: vs)) = polyArea vs
- where polyArea (v2:v3:vs') = triArea v1 v2 v3 + polyArea (v3:vs')
- polyArea _ = 0
-
- distBetween :: Vertex -> Vertex -> Float
- distBetween (x1, y1) (x2, y2) = sqrt $ (y2 - y1)^2 + (x2 - x1)^2
-
- triArea :: Vertex -> Vertex -> Vertex -> Float
- triArea v1 v2 v3 = let a = distBetween v1 v2
- b = distBetween v2 v3
- c = distBetween v3 v1
- s = (a + b + c) / 2
- in sqrt $ s * (s - a) * (s - b) * (s - c)
-
-
View
0  ch5/Main.hs
No changes.
Please sign in to comment.
Something went wrong with that request. Please try again.