gdritter repos model-utm / master Utmyen / Model / Type.hs
master

Tree @master (Download .tar.gz)

Type.hs @master — raw · history · blame 

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE BinaryLiterals #-}

module Utmyen.Model.Type where

import           Data.Bits
import           Data.ByteString
import           Data.Serialize hiding (encode)
import           Data.Vector (Vector)
import qualified Data.Vector as V
import           Data.Word

data Model = Model
  { modelPoints :: Vector Point
  , modelTris   :: Vector Word64
  } deriving (Eq, Show)

data Point = Point
  { ptX, ptY, ptZ, ptA, ptB, ptC, ptU, ptV :: Float
  } deriving (Eq, Show)

match :: Bits t => t -> t -> Bool
match mask el = mask .&. el == mask

encode :: Model -> ByteString
encode m = runPut (rModel m)

rInt :: Word64 -> Put
rInt n
  | n <= 0x7f = putWord8 (fromIntegral n)
  | n <= 0x3fff = do
      putWord8 (fromIntegral (n `shift` (-8)) .|. 0x80)
      putWord8 (fromIntegral n)
  | n <= 0x1fffff = do
      putWord8 (fromIntegral (n `shift` (-16)) .|. 0xc0)
      putWord8 (fromIntegral (n `shift` (-8)))
      putWord8 (fromIntegral n)
  | otherwise = error "XXX finish me"

pInt :: Get Word64
pInt = do
  n <- getWord8
  if | match 0b11111111 n -> go 8 0
     | match 0b11111110 n -> go 7 0
     | match 0b11111100 n -> go 6 (fromIntegral (n .&. 0b00000001))
     | match 0b11111000 n -> go 5 (fromIntegral (n .&. 0b00000011))
     | match 0b11110000 n -> go 4 (fromIntegral (n .&. 0b00000111))
     | match 0b11100000 n -> go 3 (fromIntegral (n .&. 0b00001111))
     | match 0b11000000 n -> go 2 (fromIntegral (n .&. 0b00011111))
     | match 0b10000000 n -> go 1 (fromIntegral (n .&. 0b00111111))
     | otherwise          -> go 0 (fromIntegral n)
  where go :: Int -> Word64 -> Get Word64
        go 0 r = return r
        go n r = do
          w <- getWord8
          go (n-1) (r `shift` 8 .|. fromIntegral w)

getSeveral :: Get a -> Get (Vector a)
getSeveral getter = do
  size <- fromIntegral <$> pInt
  V.generateM size (const getter)

rSeveral :: (t -> Put) -> Vector t -> Put
rSeveral putter vec = do
  rInt (fromIntegral (V.length vec))
  sequence_ (fmap putter vec)

getModel :: Get Model
getModel = do
  tris <- getSeveral pInt
  pts  <- getSeveral pPt
  return (Model pts tris)

rModel :: Model -> Put
rModel (Model pts tris) = do
  rSeveral rInt tris
  rSeveral rPt pts

pPt :: Get Point
pPt = Point <$> pF <*> pF <*> pF <*> pF <*> pF <*> pF <*> pU <*> pU

rPt :: Point -> Put
rPt (Point x y z a b c u v) = do
  mapM_ rF [x, y, z, a, b, c]
  mapM_ rU [u, v]

pF :: Get Float
pF = do
  b1 <- getWord8
  if testBit b1 7 then do
    b2 <- getWord8
    let cVal :: Word16 = (clearBit (fromIntegral b1) 7 `shift` 8) .|. fromIntegral b2
    return (fromIntegral cVal / 102.0 - 128.0)
  else
    return (fromIntegral b1 - 32.0)

rF :: Float -> Put
rF f
  | truncate (f * 100) == (truncate f :: Int) * 100
    && f >= -32.0 && f <= 95.0 =
      putWord8 (truncate (f + 32.0))
  | otherwise = do
      let ws :: Word16 = truncate ((f + 128.0) * 102.0)
          l1 = fromIntegral (ws `shift` (-8)) .|. 0x80
          l2 = fromIntegral ws
      putWord8 l1
      putWord8 l2

pU :: Get Float
pU = do
  b <- getWord8
  return (fromIntegral b / 255.0)

rU :: Float -> Put
rU f
  | f < 0.0 || f > 255.0 = error "float out of range"
  | otherwise = putWord8 $ floor (f * 255.0)