Port of mesh.hs to PureScript

mesh.purs

module Main where

import Data.Tuple
import Data.Array

import Debug.Trace

data Qt = Qt {
	qx :: Number, 
	qy :: Number, 
	qz :: Number, 
	qw :: Number
  } 

instance showQt :: Show Qt where
  show (Qt o) = "Qt { qx: " ++ show o.qx ++
                   ", qy: " ++ show o.qy ++
                   ", qz: " ++ show o.qz ++
                   ", qw: " ++ show o.qw ++ " }"

qmul :: Qt -> Qt -> Qt
qmul (Qt a) (Qt b) = Qt
  { qx: (a.qx * b.qw + a.qw * b.qx + a.qy * b.qz - a.qz * b.qy)
  , qy: (a.qy * b.qw + a.qw * b.qy + a.qz * b.qx - a.qx * b.qz)
  , qz: (a.qz * b.qw + a.qw * b.qz + a.qx * b.qy - a.qy * b.qx)
  , qw: (a.qw * b.qw - a.qx * b.qx - a.qy * b.qy - a.qz * b.qz)
  }

mkQt :: Number -> Number -> Number -> Number -> Qt
mkQt x y z w = Qt { qx: x, qy: y, qz: z, qw: w }

qinv :: Qt -> Qt
qinv (Qt a) = Qt { qx: negate a.qx, qy: negate a.qy, qz: negate a.qz, qw: a.qw }

axis_ang :: Vec -> Number -> Qt
axis_ang (Vec axis) ang = mkQt ((axis.vx) * (Math.sin (ang/2))) ((axis.vy) * (Math.sin (ang/2))) ((axis.vz) * (Math.sin (ang/2))) (Math.cos (ang/2))

data Vec = Vec {
	vx :: Number, 
	vy :: Number, 
	vz :: Number
  }

instance showVec :: Show Vec where
  show (Vec o) = "Vec { vx: " ++ show o.vx ++
                     ", vy: " ++ show o.vy ++
                     ", vz: " ++ show o.vz ++ " }"

mkVec :: Number -> Number -> Number -> Vec
mkVec x y z = Vec { vx: x, vy: y, vz: z }

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 (Vec a) = mkQt (a.vx) (a.vy) (a.vz) 0

vec_from_qt :: Qt -> Vec
vec_from_qt (Qt a) = mkVec (a.qx) (a.qy) (a.qz)

vproj :: Number -> Number -> Vec
vproj ang rad = mkVec ((Math.cos ang) * rad) ((Math.sin ang) * rad) 0

vop :: (Number -> Number -> Number) -> Vec -> Vec -> Vec
vop f (Vec a) (Vec b) = mkVec (f (a.vx) (b.vx)) (f (a.vy) (b.vy)) (f (a.vz) (b.vz))

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 :: Number, 
	g :: Number, 
	b :: Number 
  } 

instance showCol :: Show Col where
  show (Col o) = "Col { r: " ++ show o.r ++
                     ", g: " ++ show o.g ++
                     ", b: " ++ show o.b ++ " }"

mkCol :: Number -> Number -> Number -> Col
mkCol r g b = Col { r: r, g: g, b: b }

data Pivot = Pivot { 
	pivot_len :: Number, 
	pivot_rot :: Qt, 
	pivot_rads :: [Number], 
	pivot_cols:: [Col]
  }

instance showPivot :: Show Pivot where
  show (Pivot o) = "Pivot { len: " ++ show o.pivot_len ++
                   ", rot: " ++ show o.pivot_rot ++
                   ", ads: " ++ show o.pivot_rads ++
                   ", cols: " ++ show o.pivot_cols ++ " }"

mkPivot :: Number -> Qt -> [Number] -> [Col] -> Pivot
mkPivot len rot rads cols = Pivot { pivot_len: len, pivot_rot: rot, pivot_rads: rads, pivot_cols: cols }

data Mesh = Mesh {
	mesh_rot :: Qt,
	mesh_cpos :: Vec,
	mesh_positions :: [Number],
	mesh_colors :: [Number],
	mesh_indexes :: [Number]
  }

instance showMesh :: Show Mesh where
  show (Mesh o) = "Mesh { rot: " ++ show o.mesh_rot ++
                   ", cpos: " ++ show o.mesh_cpos ++
                   ", positions: " ++ show o.mesh_positions ++
                   ", colors: " ++ show o.mesh_colors ++ 
                   ", indexes: " ++ show o.mesh_indexes ++ " }"

mkMesh :: Qt -> Vec -> [Number] -> [Number] -> [Number] -> Mesh
mkMesh rot cpos positions colors indexes =
  Mesh { mesh_rot: rot
       , mesh_cpos: cpos
       , mesh_positions: positions
       , mesh_colors: colors
       , mesh_indexes: indexes
       }

faceIndexes :: Number -> Number -> Number -> Number -> [Number]
faceIndexes i j w h =
	if j < (h - 1) then
		let	a = j*w+i
			b = j*w+((i + 1) % w)
			c = (j + 1)*w+i
			d = (j + 1)*w+((i + 1) % w)
		in [a,b,d,d,c,a]
	else []

foreign import foldlWithIndex
  "function foldlWithIndex(f) {\
  \  return function(a) {\
  \    return function(bs) {\
  \      var a1 = a;\
  \      for (var i = 0; i < bs.length; i++) {\
  \        a1 = f(i)(a1)(bs[i]);\
  \      }\
  \      return a1;\
  \    };\
  \  };\
  \}" :: forall a b. (Number -> a -> b -> a) -> a -> [b] -> a

buildMesh :: [Pivot] -> Mesh
buildMesh pivots = foldlWithIndex build_layer initial pivots where	
	initial	= mkMesh (mkQt 0 0 0 1) (mkVec 0 0 0) [] [] []
	width 	= length (case Data.Array.Unsafe.head pivots of Pivot o -> o.pivot_rads)
	height	= length pivots
	depth	= 3
	build_layer j mesh'@(Mesh step) (Pivot pivot) = foldlWithIndex build_vertexes mesh' (zip pivot.pivot_rads pivot.pivot_cols) where
		rot 	= qmul step.mesh_rot pivot.pivot_rot
		cpos	= vadd step.mesh_cpos (vrot rot (mkVec 0 0 pivot.pivot_len))
		build_vertexes i (Mesh step) (Tuple vrad vcol@(Col vcol')) = mkMesh rot cpos positions colors indexes where
			vang 		= i/width*2.0*Math.pi
			vpos		= vadd cpos (vrot rot (vproj vang vrad))
			positions	= (step.mesh_positions) `concat` vecToArr vpos
			vecToArr (Vec v) = [v.vx, v.vy, v.vz]
			colors 		= (step.mesh_colors) `concat` [(vcol'.r),(vcol'.g),(vcol'.b)]
			indexes 	= (step.mesh_indexes) `concat` (faceIndexes i j width height)

replicate :: forall a. Number -> a -> [a]
replicate 0 _ = []
replicate n a = a : replicate (n - 1) a

mesh = buildMesh 
	(replicate 128
		(mkPivot 1 (mkQt 0 0 0 1) [1,1,1,1,1,1,1,1] [(mkCol 1 1 1),(mkCol 1 1 1),(mkCol 1 1 1),(mkCol 1 1 1),(mkCol 1 1 1),(mkCol 1 1 1),(mkCol 1 1 1),(mkCol 1 1 1)]))

main = print mesh