NathanHowell / bar.hs secret
Last active

Embed URL

HTTPS clone URL

SSH clone URL

You can clone with HTTPS or SSH.

Download Gist
NathanHowell revised this gist . 1 changed file with 25 additions and 18 deletions. View gist @ c676bd4
bar.hs
43 
@@ -1,10 +1,15 @@
import Prelude
+-- import Data.List
+import qualified Data.Sequence as S
+import Data.Foldable
+import Data.Monoid
+import Data.Traversable
data Qt = Qt {
- qx :: Double,
- qy :: Double,
- qz :: Double,
- qw :: Double
+ qx :: {-# UNPACK #-} !Double,
+ qy :: {-# UNPACK #-} !Double,
+ qz :: {-# UNPACK #-} !Double,
+ qw :: {-# UNPACK #-} !Double
} deriving (Show)
qmul :: Qt -> Qt -> Qt
@@ -21,9 +26,9 @@ axis_ang :: Vec -> Double -> Qt
axis_ang axis ang = Qt ((vx axis) * (sin (ang/2))) ((vy axis) * (sin (ang/2))) ((vz axis) * (sin (ang/2))) (cos (ang/2))
data Vec = Vec {
- vx :: Double,
- vy :: Double,
- vz :: Double
+ vx :: {-# UNPACK #-} !Double,
+ vy :: {-# UNPACK #-} !Double,
+ vz :: {-# UNPACK #-} !Double
} deriving (Show)
vrot :: Qt -> Vec -> Vec
@@ -67,11 +72,11 @@ data Pivot = Pivot {
} deriving (Show)
data Mesh = Mesh {
- mesh_rot :: Qt,
- mesh_cpos :: Vec,
- mesh_positions :: [Double],
- mesh_colors :: [Double],
- mesh_indexes :: [Int]
+ mesh_rot :: !Qt,
+ mesh_cpos :: !Vec,
+ mesh_positions :: !(S.Seq Double),
+ mesh_colors :: !(S.Seq Double),
+ mesh_indexes :: !(S.Seq Int)
} deriving (Show)
faceIndexes :: Int -> Int -> Int -> Int -> [Int]
@@ -86,23 +91,25 @@ faceIndexes i j w h =
buildMesh :: [Pivot] -> Mesh
-buildMesh pivots = foldl build_layer initial (zip [0..] pivots) where
- initial = Mesh (Qt 0 0 0 1) (Vec 0 0 0) [] [] []
+buildMesh pivots = foldl' build_layer initial (zip [0..] pivots) where
+ initial = Mesh (Qt 0 0 0 1) (Vec 0 0 0) S.empty S.empty S.empty
width = length (pivot_rads (head pivots))
height = length pivots
depth = 3
- build_layer step (j,pivot) = foldl build_vertexes step (zip3 [0..] (pivot_rads pivot) (pivot_cols pivot)) where
+ build_layer step (j,pivot) = foldl' build_vertexes step (zip3 [0..] (pivot_rads pivot) (pivot_cols pivot)) where
rot = qmul (mesh_rot step) (pivot_rot pivot)
cpos = vadd (mesh_cpos step) (vrot rot (Vec 0 0 (pivot_len pivot)))
build_vertexes step (i,vrad,vcol) = Mesh rot cpos positions colors indexes where
vang = ((fromIntegral i)/(fromIntegral width))*2.0*pi
vpos = vadd cpos (vrot rot (vproj vang vrad))
- positions = (mesh_positions step) ++ [(vx vpos),(vy vpos),(vz vpos)]
- colors = (mesh_colors step) ++ [(r vcol),(g vcol),(b vcol)]
- indexes = (mesh_indexes step) ++ (faceIndexes i j width height)
+ positions = (mesh_positions step) <> S.fromList [(vx vpos),(vy vpos),(vz vpos)]
+ colors = (mesh_colors step) <> S.fromList [(r vcol),(g vcol),(b vcol)]
+ indexes = (mesh_indexes step) <> S.fromList (faceIndexes i j width height)
+mesh :: Mesh
mesh = buildMesh
(replicate 128
(Pivot 1 (Qt 0 0 0 1) [1,1,1,1,1,1,1,1] [(Col 1 1 1),(Col 1 1 1),(Col 1 1 1),(Col 1 1 1),(Col 1 1 1),(Col 1 1 1),(Col 1 1 1),(Col 1 1 1)]))
+main :: IO ()
main = print mesh
NathanHowell created this gist . View gist @ b2641da
bar.hs
108 
@@ -0,0 +1,108 @@
+import Prelude
+
+data Qt = Qt {
+ qx :: Double,
+ qy :: Double,
+ qz :: Double,
+ qw :: Double
+} deriving (Show)
+
+qmul :: Qt -> Qt -> Qt
+qmul a b = Qt
+ (qx a * qw b + qw a * qx b + qy a * qz b - qz a * qy b)
+ (qy a * qw b + qw a * qy b + qz a * qx b - qx a * qz b)
+ (qz a * qw b + qw a * qz b + qx a * qy b - qy a * qx b)
+ (qw a * qw b - qx a * qx b - qy a * qy b - qz a * qz b)
+
+qinv :: Qt -> Qt
+qinv a = Qt (-(qx a)) (-(qy a)) (-(qz a)) (qw a)
+
+axis_ang :: Vec -> Double -> Qt
+axis_ang axis ang = Qt ((vx axis) * (sin (ang/2))) ((vy axis) * (sin (ang/2))) ((vz axis) * (sin (ang/2))) (cos (ang/2))
+
+data Vec = Vec {
+ vx :: Double,
+ vy :: Double,
+ vz :: Double
+} deriving (Show)
+
+vrot :: Qt -> Vec -> Vec
+vrot rot vec = vec_from_qt (qmul (qmul rot (qt_from_vec vec)) (qinv rot))
+
+qt_from_vec :: Vec -> Qt
+qt_from_vec a = Qt (vx a) (vy a) (vz a) 0
+
+vec_from_qt :: Qt -> Vec
+vec_from_qt a = Vec (qx a) (qy a) (qz a)
+
+vproj :: Double -> Double -> Vec
+vproj ang rad = Vec ((cos ang) * rad) ((sin ang) * rad) 0
+
+vop :: (Double -> Double -> Double) -> Vec -> Vec -> Vec
+vop f a b = Vec (f (vx a) (vx b)) (f (vy a) (vy b)) (f (vz a) (vz b))
+
+vadd :: Vec -> Vec -> Vec
+vadd = vop (+)
+
+vdiv :: Vec -> Vec -> Vec
+vdiv = vop (/)
+
+vsub :: Vec -> Vec -> Vec
+vsub = vop (-)
+
+vmul :: Vec -> Vec -> Vec
+vmul = vop (*)
+
+data Col = Col {
+ r :: Double,
+ g :: Double,
+ b :: Double
+} deriving (Show)
+
+data Pivot = Pivot {
+ pivot_len :: Double,
+ pivot_rot :: Qt,
+ pivot_rads :: [Double],
+ pivot_cols:: [Col]
+} deriving (Show)
+
+data Mesh = Mesh {
+ mesh_rot :: Qt,
+ mesh_cpos :: Vec,
+ mesh_positions :: [Double],
+ mesh_colors :: [Double],
+ mesh_indexes :: [Int]
+} deriving (Show)
+
+faceIndexes :: Int -> Int -> Int -> Int -> [Int]
+faceIndexes i j w h =
+ if j < (h-1) then
+ let a = j*w+i
+ b = j*w+(mod (i+1) w)
+ c = (j+1)*w+i
+ d = (j+1)*w+(mod (i+1) w)
+ in [a,b,d,d,c,a]
+ else []
+
+
+buildMesh :: [Pivot] -> Mesh
+buildMesh pivots = foldl build_layer initial (zip [0..] pivots) where
+ initial = Mesh (Qt 0 0 0 1) (Vec 0 0 0) [] [] []
+ width = length (pivot_rads (head pivots))
+ height = length pivots
+ depth = 3
+ build_layer step (j,pivot) = foldl build_vertexes step (zip3 [0..] (pivot_rads pivot) (pivot_cols pivot)) where
+ rot = qmul (mesh_rot step) (pivot_rot pivot)
+ cpos = vadd (mesh_cpos step) (vrot rot (Vec 0 0 (pivot_len pivot)))
+ build_vertexes step (i,vrad,vcol) = Mesh rot cpos positions colors indexes where
+ vang = ((fromIntegral i)/(fromIntegral width))*2.0*pi
+ vpos = vadd cpos (vrot rot (vproj vang vrad))
+ positions = (mesh_positions step) ++ [(vx vpos),(vy vpos),(vz vpos)]
+ colors = (mesh_colors step) ++ [(r vcol),(g vcol),(b vcol)]
+ indexes = (mesh_indexes step) ++ (faceIndexes i j width height)
+
+mesh = buildMesh
+ (replicate 128
+ (Pivot 1 (Qt 0 0 0 1) [1,1,1,1,1,1,1,1] [(Col 1 1 1),(Col 1 1 1),(Col 1 1 1),(Col 1 1 1),(Col 1 1 1),(Col 1 1 1),(Col 1 1 1),(Col 1 1 1)]))
+
+main = print mesh
Something went wrong with that request. Please try again.