| 1 |
{-# LANGUAGE MultiWayIf #-}
|
| 2 |
{-# LANGUAGE BinaryLiterals #-}
|
| 3 |
|
| 4 |
module Utmyen.Model.Type where
|
| 5 |
|
| 6 |
import Data.Bits
|
| 7 |
import Data.Serialize
|
| 8 |
import Data.Vector (Vector)
|
| 9 |
import qualified Data.Vector as V
|
| 10 |
import Data.Word
|
| 11 |
|
| 12 |
data Model = Model
|
| 13 |
{ modelPoints :: Vector Point
|
| 14 |
, modelTris :: Vector Word64
|
| 15 |
} deriving (Eq, Show)
|
| 16 |
|
| 17 |
data Point = Point
|
| 18 |
{ ptX, ptY, ptZ, ptA, ptB, ptC, ptU, ptV :: Float
|
| 19 |
} deriving (Eq, Show)
|
| 20 |
|
| 21 |
match :: Bits t => t -> t -> Bool
|
| 22 |
match mask el = mask .&. el == mask
|
| 23 |
|
| 24 |
rInt :: Word64 -> Put
|
| 25 |
rInt n
|
| 26 |
| n <= 0x7f = putWord8 (fromIntegral n)
|
| 27 |
| otherwise = undefined
|
| 28 |
|
| 29 |
pInt :: Get Word64
|
| 30 |
pInt = do
|
| 31 |
n <- getWord8
|
| 32 |
if | match 0b11111111 n -> go 8 0
|
| 33 |
| match 0b11111110 n -> go 7 0
|
| 34 |
| match 0b11111100 n -> go 6 (fromIntegral (n .&. 0b00000001))
|
| 35 |
| match 0b11111000 n -> go 5 (fromIntegral (n .&. 0b00000011))
|
| 36 |
| match 0b11110000 n -> go 4 (fromIntegral (n .&. 0b00000111))
|
| 37 |
| match 0b11100000 n -> go 3 (fromIntegral (n .&. 0b00001111))
|
| 38 |
| match 0b11000000 n -> go 2 (fromIntegral (n .&. 0b00011111))
|
| 39 |
| match 0b10000000 n -> go 1 (fromIntegral (n .&. 0b00111111))
|
| 40 |
| otherwise -> go 0 (fromIntegral n)
|
| 41 |
where go :: Int -> Word64 -> Get Word64
|
| 42 |
go 0 r = return r
|
| 43 |
go n r = do
|
| 44 |
w <- getWord8
|
| 45 |
go (n-1) (r `shift` 8 .|. fromIntegral w)
|
| 46 |
|
| 47 |
getSeveral :: Get a -> Get (Vector a)
|
| 48 |
getSeveral getter = do
|
| 49 |
size <- fromIntegral <$> pInt
|
| 50 |
V.generateM size (const getter)
|
| 51 |
|
| 52 |
rSeveral :: (t -> Put) -> Vector t -> Put
|
| 53 |
rSeveral putter vec = do
|
| 54 |
rInt (fromIntegral (V.length vec))
|
| 55 |
sequence_ (fmap putter vec)
|
| 56 |
|
| 57 |
getModel :: Get Model
|
| 58 |
getModel = do
|
| 59 |
tris <- getSeveral pInt
|
| 60 |
pts <- getSeveral pPt
|
| 61 |
return (Model pts tris)
|
| 62 |
|
| 63 |
rModel :: Model -> Put
|
| 64 |
rModel (Model pts tris) = do
|
| 65 |
rSeveral rInt tris
|
| 66 |
rSeveral rPt pts
|
| 67 |
|
| 68 |
pPt :: Get Point
|
| 69 |
pPt = Point <$> pF <*> pF <*> pF <*> pF <*> pF <*> pF <*> pU <*> pU
|
| 70 |
|
| 71 |
rPt :: Point -> Put
|
| 72 |
rPt (Point x y z a b c u v) = do
|
| 73 |
mapM_ rF [x, y, z, a, b, c]
|
| 74 |
mapM_ rU [u, v]
|
| 75 |
|
| 76 |
pF :: Get Float
|
| 77 |
pF = do
|
| 78 |
b1 <- getWord8
|
| 79 |
if testBit b1 7 then do
|
| 80 |
b2 <- getWord8
|
| 81 |
let cVal :: Word16 = (clearBit (fromIntegral b1) 7 `shift` 8) .|. fromIntegral b2
|
| 82 |
return (fromIntegral cVal / 102.0 - 128.0)
|
| 83 |
else
|
| 84 |
return (fromIntegral b1 - 32.0)
|
| 85 |
|
| 86 |
rF :: Float -> Put
|
| 87 |
rF _ = putWord8 0
|
| 88 |
|
| 89 |
pU :: Get Float
|
| 90 |
pU = do
|
| 91 |
b <- getWord8
|
| 92 |
return (fromIntegral b / 255.0)
|
| 93 |
|
| 94 |
rU :: Float -> Put
|
| 95 |
rU f
|
| 96 |
| f < 0.0 || f > 255.0 = error "float out of range"
|
| 97 |
| otherwise = putWord8 $ floor (f * 255.0)
|