Ticket #2284: ObjView.hs

File ObjView.hs, 7.9 KB (added by sedillard, 6 years ago)
Line 
1-- Scott Dillard, sedillard@gmail.com
2
3{-# OPTIONS -fglasgow-exts #-}
4
5module Main where
6
7import System.IO
8import System.Exit
9import Foreign
10import Foreign.C.Types
11import Control.Monad
12import Control.Parallel
13
14import Data.List
15import Data.Maybe
16import Data.Char
17import Data.Array
18
19import qualified Data.Sequence as Seq
20import qualified Data.Foldable as Fold
21import qualified Data.ByteString as B
22import qualified Data.ByteString.Lazy.Char8 as C
23
24import Data.Map (Map)
25import qualified Data.Map as Map
26
27import Data.Set (Set)
28import qualified Data.Set as Set
29
30import Data.IntMap (IntMap)
31import qualified Data.IntMap as IntMap
32
33import Graphics.UI.GLUT hiding (normalize) --why is this exported by glut?
34import Graphics.Rendering.OpenGL.GL hiding (normalize,rotate)
35import qualified Graphics.Rendering.OpenGL.GL as GL
36
37import Debug.Trace
38
39
40main = 
41  do
42
43  --initialize glut
44  initialDisplayCapabilities $= [ With DisplayRGB, With DisplayDouble, With DisplayDepth ]
45  (name,args) <- getArgsAndInitialize
46  when (null args) (error "Give me an obj file to load")
47
48  --load mesh
49  (vertList,faceList) <- loadObj (head args)
50  putStrLn $ "Loaded " ++ (head args) ++ ", " ++ show(length vertList) ++ " vertices, " ++ show(length faceList) ++ " faces." 
51
52  vertList <- return $  map vecFromList vertList
53
54  putStrLn "use x,y,z keys to rotate" 
55
56
57  let
58    nverts = length vertList
59    vertArray = listArray (0, nverts-1) vertList
60    imesh = trace "BUILDING MESH" $ memoMesh (nextMapFromLists faceList)
61    faces = findFaces imesh
62    normals = computeNormals (vertArray!) faces
63    normArray = listArray (0, nverts-1) $ IntMap.elems normals
64    lo = minimum vertList
65    hi = maximum vertList
66    center = lo `vadd` (0.5 `vmult` (hi`vsub`lo))
67    scaleFactor = 1 / vfold max (hi`vsub`lo) 
68
69  let
70    reshape size@(Size w h) = 
71      do
72      viewport $= ( Position 0 0 , size )
73
74      matrixMode $= Projection
75      loadIdentity
76      let ratio = (fromIntegral h) / (fromIntegral w)
77      ortho (-1) 1 (-ratio) ratio (-2) 2
78
79      matrixMode $= Modelview 0
80      loadIdentity
81      scale scaleFactor scaleFactor scaleFactor
82      case center of (Vec3 x y z) -> translate $ Vector3 x y z
83
84      -- init opengl
85      lighting $= Enabled
86      light (Light 0) $= Enabled
87      depthFunc $= Just Less
88      clearColor $= Color4 0 0 0 0
89     
90    display = 
91      do
92      clear [ColorBuffer, DepthBuffer]
93      color $ Color3 (0.5) (0.5::Float) 0
94      colorMaterial $= (Just (FrontAndBack,AmbientAndDiffuse))
95      lighting $= Enabled
96      GL.normalize $= Enabled
97      forM_ faces $ \f ->
98        renderPrimitive Polygon $
99          forM_ (face f) $ \(Edge i _ _) -> do
100            case normArray!i of (Vec3 x y z) -> normal $ Normal3 x y z
101            case vertArray!i of (Vec3 x y z) -> vertex $ Vertex3 x y z
102      checkGLErrors "Display"
103
104    keyMouse key keyState mods (Position x y) = 
105      do
106      case key of 
107        Char 'q' -> exitWith ExitSuccess
108        Char 'x' -> GL.rotate 1 (Vector3 1 0 (0::Float))
109        Char 'y' -> GL.rotate 1 (Vector3 0 1 (0::Float))
110        Char 'z' -> GL.rotate 1 (Vector3 0 0 (1::Float))
111        _ -> return ()
112
113  --create a window and bind callbacks
114  createWindow name
115  displayCallback $= (display >> swapBuffers) 
116  keyboardMouseCallback $= Just (\a b c d -> do keyMouse a b c d; postRedisplay Nothing)
117  reshapeCallback $= Just reshape
118
119  mainLoop
120
121
122
123
124
125--the normal at a vertex is the sum of the normals of the faces incident on it
126computeNormals :: (Int -> Vec3) -> [Edge Int] -> IntMap Vec3
127computeNormals vf faces = IntMap.map normalize $ normals (Seq.fromList faces)
128  where
129    normal e = 
130      let inds@(i:j:k:_) = map edgeOrg (face e)
131          [vi,vj,vk] = map vf [i,j,k]
132          --n = normalize $ cross (vj`vsub`vi) (vk`vsub`vi) --uniform
133          n = cross (vj`vsub`vi) (vk`vsub`vi) --area weighted
134      in  zip inds (repeat n)
135    normals s =
136      case Seq.length s of
137        n | n < 100  -> foldr (\(i,n) m -> IntMap.insertWith vadd i n m) 
138                               IntMap.empty (concatMap normal $ Fold.toList s)
139          | otherwise -> let (a,b) = Seq.splitAt (n`div`2) s
140                             a' = normals a
141                             b' = normals b
142                         in  par a' (seq b' (IntMap.unionWith vadd a' b' ))
143   
144checkGLErrors where_ = 
145  do
146  errs <- get errors
147  when (not (null errs)) $ (do putStrLn (where_++": "); (mapM_ print errs))
148 
149
150 
151 
152
153--half edge mesh
154data Edge v = Edge { edgeOrg :: v , edgeSym :: Edge v , edgeNext :: Edge v }
155
156instance Eq v => Eq (Edge v) where
157  (Edge i (Edge j _ _) _) == (Edge x (Edge y _ _) _) = (i,j) == (x,y)
158
159instance Ord v => Ord (Edge v) where
160  (Edge i (Edge j _ _) _) < (Edge x (Edge y _ _) _) = (i,j) < (x,y)
161
162instance Show v => Show (Edge v) where
163  show (Edge i _ _) = show i
164
165--given a map from nextMapFromLists, produce a memoized Edge mesh
166memoMesh :: Map (Int,Int) (Int,Int) -> Edge Int
167memoMesh nexts = head $ Map.elems ties
168  where
169    ties = Map.mapWithKey (\ij _ -> make ij) nexts
170    lookup ij = fromJust $ Map.lookup ij ties
171    make ij@(i,j) = Edge i (lookup (j,i)) 
172                           (lookup . fromJust $ Map.lookup ij nexts)
173
174faceRing e = e : faceRing (edgeNext e)
175orgRing  e = e : orgRing  (edgeNext . edgeSym $ e)
176face e = e : takeWhile (/= e) (faceRing $ edgeNext e)
177edgeVerts (Edge i (Edge j _ _) _) = (i,j)
178edgeDest (Edge _ (Edge j _ _) _) = j
179
180
181--given an Edge mesh, make a list of 1 Edge per face
182findFaces e = faces' [e] Set.empty
183  where
184    faces' [] seen = []
185    faces' (e:es) seen = 
186      let ij = edgeVerts e in
187      case Set.member ij seen of
188        True -> faces' es seen
189        False ->
190          let f = face e in
191          e : faces' (map edgeSym f ++ es) 
192                     (foldr Set.insert seen (map edgeVerts f))
193
194
195
196
197
198--given a list of faces, where each face is a list of vertex indicies,
199--construct a map from an edge (Int,Int) to the next edge around the left face
200--of that edge, in ccw order
201
202nextMapFromLists :: [[Int]] -> Map (Int,Int) (Int,Int)
203nextMapFromLists faces = make (Seq.fromList faces)
204  where
205    pairs xs = xs `zip` (tail . cycle $ xs)
206    make s =
207      case Seq.length s of
208        n | n<100 -> foldr (\(e,f) m -> Map.insert e f m) 
209                           Map.empty (Fold.concatMap (pairs . pairs) s)
210          | otherwise -> 
211              let (a,b) = Seq.splitAt (n`div`2) s
212                  a' = make a
213                  b' = make b
214              in  par a' $ seq b' $ Map.union (make a) (make b)
215
216
217
218
219--load an Obj model file (old alias/wavefront format, blender and wings3d can
220--read/write it. This is barebones, but works with wings3d's exported files)
221
222loadObj :: String -> IO ([[Double]],[[Int]])
223loadObj filename =
224  do
225  txt <- C.hGetContents =<< openFile filename ReadMode
226  let
227    (verts,faces) = foldl' doLine ([],[]) $ C.lines txt
228    doLine :: ([[Double]],[[Int]]) -> C.ByteString -> ([[Double]],[[Int]])
229    doLine (vls,fls) line =
230      case C.head line of 
231        'v' -> 
232          case C.head $ C.tail line of 
233            ' ' -> (map readDouble (C.words ((C.tail . C.tail)line)) : vls, fls)
234            _ -> (vls,fls)
235        'f' -> 
236          (vls, (map (pred . (fst . fromJust . C.readInt) . (C.takeWhile isDigit)) ((C.words . C.tail) line)):fls )
237        _ -> (vls,fls)
238  return (reverse verts,faces)
239
240readDouble :: C.ByteString -> Double
241readDouble ls = unsafePerformIO $ B.useAsCString s $ \cstr ->
242    realToFrac `fmap` c_strtod cstr nullPtr
243  where
244    s = B.concat . C.toChunks $ ls
245
246foreign import ccall unsafe "static stdlib.h strtod" c_strtod
247    :: Ptr CChar -> Ptr (Ptr CChar) -> IO CDouble
248
249
250
251
252
253
254data Vec3 = Vec3 !Double !Double !Double deriving (Eq,Ord,Show)
255cross (Vec3 ux uy uz) (Vec3 vx vy vz) = Vec3 (uy*vz-uz*vy) (uz*vx-ux*vz) (ux*vy-uy*vx) 
256normalize (Vec3 x y z) = case sqrt(x*x+y*y+z*z) of n -> Vec3 (x/n) (y/n) (z/n)
257vfold f (Vec3 x y z) = x`f`y`f`z
258vadd (Vec3 x y z) (Vec3 a b c) = Vec3 (x+a) (y+b) (z+c)
259vsub (Vec3 x y z) (Vec3 a b c) = Vec3 (x-a) (y-b) (z-c)
260vmult s (Vec3 a b c) = Vec3 (s*a) (s*b) (s*c)
261vecFromList [x,y,z] = Vec3 x y z
262