Correct text scaling

shader/character.geom

@@ -2,30 +2,31 @@
 layout (points) in;
 layout (triangle_strip, max_vertices = 4) out;
 in vec4 vColor [];
-in vec2 vTexCoord [];
+in vec3 vTexCoord [];
 out vec4 gColor;
 out vec2 gTex;
 void main()
 {
   vec3 cenPos = gl_in[0].gl_Position.xyz;
-  float size = vTexCoord[0].y;
+  float sizex = vTexCoord[0].y;
+  float sizey = vTexCoord[0].z;
   //float size = 0.05;
   gColor = vColor[0];
   float texPos = vTexCoord[0].x;
 
-  gl_Position = vec4 (cenPos.x - size*0.5, cenPos.y - size, cenPos.z , 1);
+  gl_Position = vec4 (cenPos.x - sizex*0.5, cenPos.y - sizey*0.5, cenPos.z , 1);
   //gl_Position = vec4 (0, 0 , 5 , 1);
   gTex = vec2 (texPos*0.0078125, 1);
   EmitVertex();
-  gl_Position = vec4 (cenPos.x - size*0.5, cenPos.y + size, cenPos.z , 1);
+  gl_Position = vec4 (cenPos.x - sizex*0.5, cenPos.y + sizey*0.5, cenPos.z , 1);
   //gl_Position = vec4 (0, 0.5 , 5 , 1);
   gTex = vec2 (texPos*0.0078125, 0);
   EmitVertex();
-  gl_Position = vec4 (cenPos.x + size*0.5, cenPos.y - size, cenPos.z , 1);
+  gl_Position = vec4 (cenPos.x + sizex*0.5, cenPos.y - sizey*0.5, cenPos.z , 1);
   //gl_Position = vec4 (0.5, 0.5 , -5 , 1);
   gTex = vec2 ((texPos+1)*0.0078125, 1);
   EmitVertex();
-  gl_Position = vec4 (cenPos.x + size*0.5, cenPos.y + size, cenPos.z , 1);
+  gl_Position = vec4 (cenPos.x + sizex*0.5, cenPos.y + sizey*0.5, cenPos.z , 1);
   gTex = vec2 ((texPos+1)*0.0078125, 0);
   //gl_Position = vec4 (0.5, 0 , -5 , 1);
   EmitVertex();

shader/character.vert

@@ -1,7 +1,7 @@
 #version 430 core
 layout (location = 0) in vec3 aPos;
 layout (location = 1) in vec4 aColor;
-layout (location = 2) in vec2 aTexCoord;
+layout (location = 2) in vec3 aTexCoord;
 
 uniform vec2 winSize;
 uniform float zoom;
@@ -10,7 +10,7 @@ uniform float rotation;
 uniform mat4 worldMat;
 
 out vec4 vColor;
-out vec2 vTexCoord;
+out vec3 vTexCoord;
 
 void main()
 {

src/Dodge/Rendering.hs

@@ -229,7 +229,7 @@ drawCursor w = setLayer 1
                 $ translate (105-halfWidth w) 
                          (halfHeight w - (25* (fromIntegral iPos)) - 20
                          )
-                 $ line [(200,12.5),(-100,12.5),(-100,-12.5),(200,-12.5)]
+                 $ line [(100,12.5),(-100,12.5),(-100,-12.5),(100,-12.5)]
     where iPos = _crInvSel $ _creatures w IM.! _yourID w
 
 
@@ -436,8 +436,8 @@ displayInv n w = pictures $ zipWith (translate (10-halfWidth w))
                          (map (\x-> halfHeight w-(25*(fromIntegral x+1))) ns) $ map dItem' is
      where (ns,is) = unzip $ IM.toList $ _crInv $ _creatures w IM.! n
 
-dItem' NoItem = scale 0.15 0.15 $ dShadCol (greyN 0.5) $ text "----"
+dItem' NoItem = scale 0.1 0.1 $ dShadCol (greyN 0.5) $ text "----"
-dItem' i = scale 0.15 0.15 $ pictures [dropShadow t, color (_itInvColor i) t]
+dItem' i = scale 0.1 0.1 $ pictures [dropShadow t, color (_itInvColor i) t]
     where t = text $ _itInvDisplay i i
 
 displayAmount :: Int -> String

src/Picture.hs

@@ -112,7 +112,7 @@ scale3 a b (x,y,z) = (x*a,y*b,z)
 
 scale :: Float -> Float -> Picture -> Picture
 {-# INLINE scale #-}
-scale x y pic = OverPic (scale3 x y) ((*) x) 0 id pic
+scale x y pic = OverPic (scale3 x y) (\(a,b) ->(a*x,b*y)) 0 id pic
 
 rotate3 :: Float -> Point3 -> Point3
 {-# INLINE rotate3 #-}

src/Picture/Data.hs

@@ -57,7 +57,7 @@ flat4 (x,y,z,w) = [x,y,z,w]
 
 data RenderType
     = RenderPoly [(Point3,Point4)]
-    | RenderText [(Point3,Point4,Point2)]
+    | RenderText [(Point3,Point4,Point3)]
     | RenderCirc (Point3,Point4,Float)
     | RenderArc  (Point3,Point4,Point4)
     | RenderLine [(Point3,Point4)]
@@ -71,7 +71,7 @@ data Picture
     | ThickArc Int Float Float Float Float
     | Line Int [Point2]
     | Pictures [Picture]
-    | OverPic (Point3 -> Point3) (Float -> Float) Float (Point4 -> Point4) Picture
+    | OverPic (Point3 -> Point3) (Point2 -> Point2) Float (Point4 -> Point4) Picture
     | OnLayer Int Picture
 
 

src/Picture/Preload.hs

@@ -143,14 +143,18 @@ preloadRender = do
 
     --textureBinding Texture2D $= Just chartex
 
+-- input a list of (attribute location, attrib length) pairs
+-- these will have buffers and pointers created
     trivao  <- setupVAO [(0,3),(1,4)]
     linevao <- setupVAO [(0,3),(1,4)]
-    textvao <- setupVAO [(0,3),(1,4),(2,2)]
+    textvao <- setupVAO [(0,3),(1,4),(2,3)]
     circvao <- setupVAO [(0,3),(1,4),(2,1)]
     arcvao  <- setupVAO [(0,3),(1,4),(2,4)]
-    backgroundvao <- setupVAO [(0,4),(1,2)]
+    backgroundvao 
+            <- setupVAO [(0,4),(1,2)]
     wallvao <- setupVAO [(0,4),(1,4)]
-    fadecircvao <- setupVAO [(0,4)]
+    fadecircvao 
+            <- setupVAO [(0,4)]
     
     return $ RenderData
         { -- _charMap      = convertRGBA8 cmap

src/Picture/Render.hs

@@ -6,9 +6,7 @@ import Control.Lens
 import Control.Monad
 
 import qualified Control.Applicative as Ap
---import Control.Monad.Trans.State
+
---
---
 import Linear.Matrix
 import Linear.V4
 
@@ -20,7 +18,6 @@ import Picture.Data
 import Geometry
 
 import Picture.Preload
---import Control.Lens
 
 import Foreign hiding (rotate)
 
@@ -57,9 +54,9 @@ tripSecond :: (b -> b') -> (a,b,c) -> (a,b',c)
 {-# INLINE tripSecond #-}
 tripSecond f (x,y,z) = (x,f y,z)
 
-scaleT :: Float -> (Point3,Point4,Point2) -> (Point3,Point4,Point2)
+scaleT :: (Float,Float) -> (Point3,Point4,Point3) -> (Point3,Point4,Point3)
 {-# INLINE scaleT #-}
-scaleT x (a,b,(o,s)) = (a,b,(o,s*x))
+scaleT (x,y) (a,b,(o,s,t)) = (a,b,(o,s*x,t*y))
 
 overPos :: (Point3 -> Point3) -> RenderType -> RenderType
 {-# INLINE overPos #-}
@@ -82,14 +79,14 @@ overCol f (RenderText vs) = RenderText $ map (\(a,b,c) -> (a,f b,c)) vs
 overCol f (RenderCirc (a,b,c)) = RenderCirc (a,f b,c)
 overCol f (RenderArc (a,b,c)) = RenderArc (a,f b,c)
 
-overSca :: (Float -> Float) -> RenderType -> RenderType
+overSca :: (Point2 -> Point2) -> RenderType -> RenderType
 {-# INLINE overSca #-}
-overSca f (RenderText vs) = RenderText $ map (scaleT (f 1)) vs
+overSca f (RenderText vs) = RenderText $ map (scaleT (f (1,1))) vs
 overSca f p = p
 
 scaleRen,translateRen :: Float -> Float -> RenderType -> RenderType
 {-# INLINE scaleRen #-}
-scaleRen x y (RenderText vs) = overPos (scale3 x y) $ RenderText $ map (scaleT x) vs
+scaleRen x y (RenderText vs) = overPos (scale3 x y) $ RenderText $ map (scaleT (x,y)) vs
 scaleRen x y rt = overPos (scale3 x y) rt
 {-# INLINE translateRen #-}
 translateRen x y = overPos $ translate3 x y
@@ -105,16 +102,18 @@ setDepthRen d = overPos $ \(x,y,_) -> (x,y,-d)
 colorRen :: RGBA -> RenderType -> RenderType
 colorRen c = overCol $ const c
 
-stringToList :: String -> [(Point3,Point4,Point2)]
+stringToList :: String -> [(Point3,Point4,Point3)]
 {-# INLINE stringToList #-}
 stringToList s = zipWith (\x (a,b,c) -> (translate3 x 0 a,b,c))
                          [0,0.9*dimText..]
                          $ map charToTuple s
-    where dimText = 100
+    --where dimText = 100
+dimText :: Float
+dimText = 100
 
-charToTuple :: Char -> (Point3,Point4,Point2)
+charToTuple :: Char -> (Point3,Point4,Point3)
 {-# INLINE charToTuple #-}
-charToTuple c = ((0,0,0),white,(offset,100))
+charToTuple c = ((0,0,0),white,(offset,dimText,2*dimText))
     where offset = fromIntegral (fromEnum c) - 32
 
 picToAlt :: (Ap.Alternative f, Monoid (f RenderType)) => Int -> Picture -> f RenderType
@@ -167,36 +166,6 @@ picToList x (Text i s)
 picToList j Blank = []
 picToList j (Pictures pics) = concatMap (picToList j) pics
 
--- picToFTree :: Int -> Picture -> FTree RenderType
--- {-# INLINE picToFTree #-}
--- picToFTree x (Polygon i ps) 
---     | i == x = FLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black
---     | otherwise = FLeaf RenderBlank
--- picToFTree x (PolygonCol i vs) 
---     | i /= x = FLeaf RenderBlank
---     | otherwise = 
---         let (ps,cs) = unzip vs
---         in  FLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ polyToTris cs
--- picToFTree x (Circle i r) 
---     | i == x = FLeaf $ RenderCirc $ ((0,0,0),black,r)
---     | otherwise = FLeaf RenderBlank
--- picToFTree x (ThickArc i startA endA rad wdth) 
---     | i == x = FLeaf $ RenderArc $ ((0,0,0),black,(startA,endA,rad,wdth))
---     | otherwise = FLeaf RenderBlank
--- picToFTree x (Line i ps) 
---     | i == x = FLeaf $ RenderLine $ zip (map zeroZ $ doubleLine ps) $ repeat white
---     | otherwise = FLeaf RenderBlank
--- picToFTree x (Text i s) 
---     | i == x = FLeaf $ RenderText $ stringToList s
---     | otherwise = FLeaf RenderBlank
--- picToFTree j Blank = FLeaf RenderBlank
--- picToFTree j (Scale x y pic) = collapseBranch (scaleRen x y) $ picToFTree j pic
--- picToFTree j (Translate x y pic) = collapseBranch (translateRen x y) $ picToFTree j pic
--- picToFTree j (Rotate a pic) = collapseBranch (rotateRen a) $ picToFTree j pic
--- picToFTree j (SetDepth a pic) = collapseBranch (setDepthRen a) $ picToFTree j pic
--- picToFTree j (Color c pic) = collapseBranch (colorRen c) $ picToFTree j pic
--- picToFTree j (Pictures pics) = FBranches $ map (picToFTree j) pics
-
 collapseBranch :: (RenderType -> RenderType) -> FTree RenderType -> FTree RenderType
 collapseBranch f (FBranch g t) = FBranch (f . g) t
 collapseBranch f (FBranches ts) = FBranches $ map (collapseBranch f) ts
@@ -246,7 +215,6 @@ theFold :: TwoPtrs
         -> ThreePtrs
         -> F.FoldM IO RenderType (Int,Int,Int,Int,Int)
 theFold pas pbs pcs pds pes 
-   -- = (,,,,) <$> pokeFold pas <*> pokeTextFold pbs <*> pokeCircFold pcs
     = (,,,,) <$> pokeTwoPtrsWith pokePoly pas 
              <*> pokeThreePtrsWith pokeText pbs 
              <*> pokeThreePtrsWith pokeCirc pcs
@@ -327,14 +295,14 @@ pokeText :: (Ptr Float, Ptr Float, Ptr Float) -> Int -> RenderType -> IO Int
 pokeText (pa,pb,pc) n  (RenderText vs) = foldM (pokeTextVert pa pb pc) n vs
 pokeText _          n _               = return n
 
-pokeTextVert :: Ptr Float -> Ptr Float -> Ptr Float -> Int -> (Point3, Point4, Point2) -> IO Int
+pokeTextVert :: Ptr Float -> Ptr Float -> Ptr Float -> Int -> (Point3, Point4, Point3) -> IO Int
 {-# INLINE pokeTextVert #-}
 pokeTextVert pa pb pc n (p,c,t)
     | n > 20000 * 2 = return n
     | otherwise = do
         pokeThreeOff pa n p
         pokeFourOff  pb n c
-        pokeTwoOff   pc n t
+        pokeThreeOff pc n t
         return (n+1)
 
 pokePoly :: TwoPtrs -> Int -> RenderType -> IO Int