packages feed

gluturtle 0.0.3 → 0.0.4

raw patch · 5 files changed

+257/−9 lines, 5 files

Files

gluturtle.cabal view
@@ -2,7 +2,7 @@ cabal-version:	>= 1.6  name:		gluturtle-version:	0.0.3+version:	0.0.4 stability:	alpha author:		Yoshikuni Jujo <PAF01143@nifty.ne.jp> maintainer:	Yoshikuni Jujo <PAF01143@nifty.ne.jp>@@ -29,6 +29,7 @@   Other-modules:	Graphics.UI.GLUT.Turtle.Field, Graphics.UI.GLUT.Turtle.Input,     Graphics.UI.GLUT.Turtle.Move, Graphics.UI.GLUT.Turtle.State,     Graphics.UI.GLUT.Turtle.Data, Graphics.UI.GLUT.Turtle.Layers+    Graphics.UI.GLUT.Turtle.Triangles, Graphics.UI.GLUT.Turtle.TriangleTools  executable		testTurtle   Hs-source-dirs:	tests, src
src/Graphics/UI/GLUT/Turtle/Field.hs view
@@ -52,6 +52,8 @@ import System.Exit import Control.Applicative +import Graphics.UI.GLUT.Turtle.Triangles+ import Graphics.UI.GLUT( 	createWindow, Vertex2(..), renderPrimitive, vertex, PrimitiveMode(..), 	preservingMatrix, GLfloat, swapBuffers, ($=), displayCallback,@@ -110,8 +112,8 @@ 	layers <- newLayers 0 (return ()) (return ()) (return ()) 	action <- newIORef $ return () 	actions <- newIORef []-	str <- newIORef "coi rodo"-	str2 <- newIORef "hello"+	str <- newIORef ""+	str2 <- newIORef "coi rodo" 	inputtext <- newIORef $ const $ return True  	initialDisplayMode $= [RGBMode, DoubleBuffered]@@ -242,11 +244,30 @@ colorToColor4 (RGB r g b) = G.Color4 	(fromIntegral r / 255) (fromIntegral g / 255) (fromIntegral b / 255) 0 -makeCharacterAction :: [Position] -> IO ()-makeCharacterAction ps =+makeCharacterAction :: [Position] -> Color -> Color -> Double -> IO ()+makeCharacterAction ps c lc lw = 	preservingMatrix $ do-		renderPrimitive Polygon $ mapM_ (vertex . positionToVertex3) ps+		print ps+		G.color $ colorToColor4 c+		renderPrimitive Triangles $ mapM_ (vertex . positionToVertex3) $+			map posToPosition $ triangleToPositions $+			toTriangles $ map positionToPos ps+--		renderPrimitive Polygon $ mapM_ (vertex . positionToVertex3) ps+		G.lineWidth $= fromRational (toRational lw)+		G.color $ colorToColor4 lc+		renderPrimitive LineLoop $ mapM_ (vertex . positionToVertex3) ps +type Pos = (Double, Double)+triangleToPositions :: [(Pos, Pos, Pos)] -> [Pos]+triangleToPositions [] = []+triangleToPositions ((a, b, c) : rest) = a : b : c : triangleToPositions rest++positionToPos :: Position -> Pos+positionToPos (Center x y) = (x, y)++posToPosition :: Pos -> Position+posToPosition (x, y) = Center x y+ positionToVertex3 :: Position -> Vertex2 GLfloat positionToVertex3 (Center x y) = 	Vertex2 (fromRational $ toRational x / 300)@@ -264,7 +285,7 @@  fillPolygon :: Field -> Layer -> [Position] -> Color -> Color -> Double -> IO () fillPolygon f l ps clr lc lw = do-	atomicModifyIORef_ (fActions f) (makeCharacterAction ps :)+	atomicModifyIORef_ (fActions f) (makeCharacterAction ps clr lc lw :)  -------------------------------------------------------------------------------- @@ -276,7 +297,7 @@ drawCharacterAndLine f ch fclr clr sh lw p q = 	writeIORef (fAction f) $ do 		makeLineAction p q clr lw-		makeCharacterAction sh+		makeCharacterAction sh fclr clr lw  clearCharacter :: Character -> IO () clearCharacter ch = character ch $ return ()@@ -309,7 +330,8 @@ 	($ str) =<< readIORef (fInputtext f) 	writeIORef (fString2 f) str 	writeIORef (fString f) ""+keyboardProc f (G.Char '\b') G.Down _ _ = atomicModifyIORef_ (fString f) init keyboardProc f (G.Char c) state _ _-	| state == G.Down = atomicModifyIORef_ (fString f) (++ [c])+	| state == G.Down = print c >> atomicModifyIORef_ (fString f) (++ [c]) 	| otherwise = return () keyboardProc _ _ _ _ _ = return ()
+ src/Graphics/UI/GLUT/Turtle/TriangleTools.hs view
@@ -0,0 +1,186 @@+module Graphics.UI.GLUT.Turtle.TriangleTools (+	Pos,+	far,+--	maximumIndex,+--	distance2,+	index3,+	deleteIndex,++	distant3,+	within,+	isRight,+	online,+	deleteOnline,+	draw,++	pa, pb, pc, pd, pe+) where++import Graphics.UI.GLUT+import System.Environment++far :: [Pos] -> Int+far = maximumIndex . map distance2++deleteOnline xs = init $ tail $ dol $ last xs : xs ++ [head xs]++dol :: [Pos] -> [Pos]+dol [a, b] = [a, b]+dol (a : ps@(b : ps'@(c : _)))+	| online (a, b, c) = a : dol ps'+	| otherwise = a : dol ps++maximumIndex :: Ord a => [a] -> Int+maximumIndex = fst . maximumIndexGen++index3 :: [a] -> Int -> (a, a, a)+index3 xs i = (xs' !! i, xs' !! (i + 1), xs' !! (i + 2))+	where+	xs' = last xs : xs ++ [head xs]++deleteIndex :: [a] -> Int -> [a]+deleteIndex xs i = take i xs ++ drop (i + 1) xs++maximumIndexGen :: Ord a => [a] -> (Int, a)+maximumIndexGen [x] = (0, x)+maximumIndexGen (x : xs)+	| x >= x' = (0, x)+	| otherwise = (i + 1, x')+	where+	(i, x') = maximumIndexGen xs++draw pl trs = do+	prgName <- getProgName+	rawArgs <- getArgs+	args <- initialize prgName rawArgs+	createWindow "GLTest"+	displayCallback $= do+		color $ (Color4 1 1 1 0 :: Color4 GLfloat)+		drawTriangles trs -- [((50, 50), (-50, -50), (0, 50))]+		color $ (Color4 1 0 0 0 :: Color4 GLfloat)+		drawPolyline pl -- [(50, 50), (-50, -50), (0, 50), (-50, 80)]+		swapBuffers+		flush+	mainLoop++main = do+	prgName <- getProgName+	rawArgs <- getArgs+	args <- initialize prgName rawArgs+	createWindow "GLTest"+	displayCallback $= displayScene+	mainLoop++displayScene = do+--	drawTriangles [(50, 50), (-50, -50), (0, 50)]+	drawPolyline [(50, 50), (-50, -50), (0, 50), (-50, 80)]+	swapBuffers+	flush++drawObject = preservingMatrix $+	renderPrimitive Lines $ mapM_ vertex [+		Vertex2 (-0.5) (-0.5),+		Vertex2 0.5 0.5 :: Vertex2 GLfloat ]++drawTriangles ps = preservingMatrix $+	renderPrimitive Triangles $ mapM_ vertex $ trianglesToVertex2 ps++trianglesToVertex2 :: [(Pos, Pos, Pos)] -> [Vertex2 GLfloat]+trianglesToVertex2 [] = []+trianglesToVertex2 ((a, b, c) : rest) =+	toVertex2 a : toVertex2 b : toVertex2 c : trianglesToVertex2 rest++toVertex2 :: (Double, Double) -> Vertex2 GLfloat+toVertex2 (x, y) = Vertex2+	(fromRational $ toRational x / 20) (fromRational $ toRational y / 20)++drawPolyline ps = preservingMatrix $+	renderPrimitive LineLoop $ mapM_ (vertex . toVertex2) ps++type Pos = (Double, Double)++isRight :: (Pos, Pos, Pos) -> Bool+isRight ((xa, ya), (xb, yb), (xc, yc))+	| 0 < xd * ye - xe * yd = True+	| 0 == xd * ye - xe * yd = error "bad triangle"+	| otherwise = False+	where+	(xd, yd) = (xa - xb, ya - yb)+	(xe, ye) = (xc - xb, yc - yb)++distance2 (x, y) = x ** 2 + y ** 2++maximum3 :: Ord a => [a] -> (a, a, a)+maximum3 xs = maximum3Gen $ last xs : xs ++ [head xs]++maximum3Gen :: Ord a => [a] -> (a, a, a)+maximum3Gen [x, y, z] = (x, y, z)+maximum3Gen (x : xs@(y : z : _))+	| y > y' = (x, y, z)+	| otherwise = p+	where+	p@(x', y', z') = maximum3Gen xs++maximumby3 :: Ord b => (a -> b) -> [a] -> (a, a, a)+maximumby3 b xs = maximumby3Gen b $ last xs : xs ++ [head xs]++maximumby3Gen :: Ord b => (a -> b) -> [a] -> (a, a, a)+maximumby3Gen _ [x, y, z] = (x, y, z)+maximumby3Gen b (x : xs@(y : z : _))+	| b y > b y' = (x, y, z)+	| otherwise = p+	where+	p@(_, y', _) = maximumby3Gen b xs++maximumby32 b xs = maximumby3Gen2 b $ last xs : xs ++ [head xs]++maximumby3Gen2 :: Ord b => (a -> b) -> [a] -> ((a, a, a), [a])+maximumby3Gen2 _ [x, y, z] = ((x, y, z), [x, z])+maximumby3Gen2 b (x : ys@(y : (zs@(z : _))))+	| b y > b y' = ((x, y, z), x : zs)+	| otherwise = (t, x : ps)+	where+	(t@(_, y', _), ps) = maximumby3Gen2 b ys++distant3 :: [Pos] -> ((Pos, Pos, Pos), [Pos])+distant3 ps = let (t, ps') = maximumby32 distance2 ps in (t, init $ tail ps')++within :: (Pos, Pos, Pos) -> Pos -> Bool+within (a, b, c) d+	| online (d, a, b) || online (d, b, c) || online (d, c, a) = False+	| otherwise = isRight (a, b, c) &&+		isRight (d, a, b) && isRight (d, b, c) && isRight (d, c, a)++online :: (Pos, Pos, Pos) -> Bool+online ((xa, ya), (xb, yb), (xc, yc)) = 0 == xd * ye - xe * yd+	where+	(xd, yd) = (xa - xb, ya - yb)+	(xe, ye) = (xc - xb, yc - yb)++deleteOnlineGen :: (Pos, Pos, Pos) -> (Pos, Pos)+deleteOnlineGen (p1@(x1, _), p2@(x2, _), p3@(x3, _))+	| not $ online (p1, p2, p3) = error "not online"+	| x1 > x3 = deleteOnlineGen (p3, p2, p1)+	| x2 < x1 = (p2, p3)+	| x1 <=x2 && x2 <= x3 = (p1, p3)+	| x3 < x2 = (p1, p2)++pa, pb, pc, pd, pe :: Pos+pa = (0, 4)+pb = (4, 4)+pc = (4, 0)+pd = (3, 3)+pe = (2, 2)++{-+deleteOnline :: [Pos] -> [Pos]+deleteOnline xs = deleteOnline' $ last xs : xs ++ [head xs]++deleteOnline' :: [Pos] -> [Pos]+deleteOnline' ps@[_, _] = ps+deleteOnline' (a : ps@(b : c : ps'))+	| online (a, b, c) = deleteOnline' $ a' : b' : ps'+	| otherwise = a : deleteOnline' ps+	where+	(a', b') = deleteOnlineGen (a, b, c)+-}
+ src/Graphics/UI/GLUT/Turtle/Triangles.hs view
@@ -0,0 +1,35 @@+module Graphics.UI.GLUT.Turtle.Triangles(toTriangles) where++import Graphics.UI.GLUT.Turtle.TriangleTools++ps = [pa, pb, pc, pd]+ps' = [(1, 3), (2.1, 2), (3, 3.1), (5, 2), (4, 1), (2, 1.5), (1, 1.1)]++main = draw ps' $ toTriangles ps'++toTriangles :: [Pos] -> [(Pos, Pos, Pos)]+toTriangles ps = toTrianglesTop ps'+--	| isRight tri = toTrianglesTop ps'+--	| otherwise = toTrianglesTop $ reverse ps'+	where+	ps' = deleteOnline ps+	(tri, rest) = distant3 ps++toTrianglesTop :: [Pos] -> [(Pos, Pos, Pos)]+toTrianglesTop [a, b, c] = [(a, b, c)]+toTrianglesTop ps+	| any (within tri) ps = toTrianglesNext (isRight tri) i ps+	| otherwise = tri : toTrianglesTop rest+	where+	i = far ps+	tri = index3 ps i+	rest = deleteIndex ps i++toTrianglesNext :: Bool -> Int -> [Pos] -> [(Pos, Pos, Pos)]+toTrianglesNext r i ps+	| isRight tri /= r || any (within tri) ps = toTrianglesNext r next ps+	| otherwise = tri : toTrianglesTop rest+	where+	tri = index3 ps i+	rest = deleteIndex ps i+	next = if i == 0 then length ps - 1 else i - 1
tests/testGLUT.hs view
@@ -12,6 +12,7 @@ 	t <- newTurtle f 	oninputtext f (processInput t) --	speed t "slowest"+	fillcolor t (255, 255, 255) 	pencolor t (255, 255, 255) --	threadDelay 1000000 --	left t 45@@ -27,4 +28,7 @@ processInput t "bold" = pensize t 3 >> return True processInput t "big" = shapesize t 3 3 >> return True processInput t "blue" = pencolor t (0, 0, 255) >> return True+processInput t "fblue" = fillcolor t (0, 0, 255) >> return True+processInput t "yellow" = pencolor t (255, 255, 0) >> return True+processInput t "normal" = pensize t 1 >> return True processInput t _ = return True