bar-extend

{-# LANGUAGE DeriveGeneric #-}
module Bar where
-- import Data.List

import qualified Data.Sequence as S
import GHC.Generics
import Data.Foldable
import Data.Monoid
import System.IO 
import qualified Data.ByteString as B
import qualified Data.ByteString.Builder as B
import qualified Data.ByteString.Lazy as BL
import Data.Traversable
import Data.Aeson 

data Qt = Qt {
	qx :: {-# UNPACK #-} !Double, 
	qy :: {-# UNPACK #-} !Double, 
	qz :: {-# UNPACK #-} !Double, 
	qw :: {-# UNPACK #-} !Double
} deriving (Show,Generic)

instance ToJSON Qt where


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 :: {-# UNPACK #-} !Double, 
	vy :: {-# UNPACK #-} !Double, 
	vz :: {-# UNPACK #-} !Double
} deriving (Generic)

instance ToJSON Vec where

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 (Generic)

instance ToJSON Col where

data Pivot = Pivot { 
	pivot_len :: Double, 
	pivot_rot :: Qt, 
	pivot_rads :: [Double], 
	pivot_cols:: [Col]
} deriving (Generic)


instance ToJSON Pivot where

data Mesh = Mesh {
	mesh_rot :: !Qt,
	mesh_cpos :: !Vec,
	mesh_positions :: !(S.Seq Double),
	mesh_colors :: !(S.Seq Double),
	mesh_indexes :: !(S.Seq Int)
} deriving (Generic)

instance ToJSON Mesh where 

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) 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
		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) <> 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)]))



-- hPutBuilder :: Handle -> Builder -> IO ()
runBar :: IO () 
runBar = (B.hPutBuilder stdout) . B.byteString . BL.toStrict .encode $ mesh


instance (ToJSON a) =>  ToJSON (S.Seq a) where 
    toJSON s = toJSON. toList $ s