Logos.hs 17.5 KB
Newer Older
1
{-# LANGUAGE DeriveGeneric, TypeFamilies, ScopedTypeVariables, ExistentialQuantification, PatternSynonyms #-}
2
3
4
module Main where

import Algebra.Monad.Concatenative
5
6
import Codec.Picture hiding (Uniform)
import Console.Readline (readline,addHistory,setCompletionEntryFunction)
7
import Control.Concurrent (threadDelay, forkIO, killThread)
8
9
10
import Control.Exception (SomeException(..),Exception)
import Data.IORef
import Data.Matricial
11
import Data.StateVar (($=))
12
import Definitive
13
import Foreign.Ptr
14
import Foreign.Storable
15
16
import GHC.Generics (Generic)
import Language.Parser
17
18
19
import System.Environment (getArgs)
import System.IO (hIsTerminalDevice)
import System.IO.Unsafe (unsafeInterleaveIO)
20
import Control.Concurrent.Chan
21
22
23
24
25

import qualified Data.StateVar as SV
import qualified Data.Vector.Storable as V
import qualified Graphics.Rendering.OpenGL as GL
import qualified Graphics.UI.GLFW as GLFW
26

27
28
29
30
setUniformMat u (V4 (V4 a b c d) (V4 e f g h) (V4 i j k l) (V4 m n o p)) = do
  m <- GL.newMatrix GL.ColumnMajor [a,e,i,m, b,f,j,n, c,g,k,o, d,h,l,p]
  GL.uniform u $= (m :: GL.GLmatrix GL.GLfloat)

31
32
33
34
35
36
37
38
39
40
41
42
43
44
stringWords :: String -> [String]
stringWords = map fromString . fromBlank
  where fromBlank (c:t) | c `elem` [' ', '\t', '\r', '\n'] = fromBlank t
                        | c == '"' = fromQuote id t
                        | otherwise = fromWChar (c:) t
        fromBlank "" = []
        fromQuote k ('"':t) = ('"':k "\""):fromBlank t
        fromQuote k ('\\':c:t) = fromQuote (k.(qChar c:)) t
          where qChar 'n' = '\n' ; qChar 't' = '\t' ; qChar x = x
        fromQuote k (c:t) = fromQuote (k.(c:)) t
        fromQuote k "" = ['"':k "\""]
        fromWChar k (c:t) | c `elem` [' ', '\t', '\r', '\n'] = k "":fromBlank t
                          | otherwise = fromWChar (k.(c:)) t
        fromWChar k "" = [k ""]
45
  
46
data LogosBuiltin = Wait | Quit | Format | Print | OpenWindow | Texture | BuildMesh | Draw | Uniform | DefUniform
47
                  | VCons | MCons | Norm | Rotation | Translation | Skew | Ejection | MCompose | Transpose | MAdd | Recip
48
                  deriving Show
49
50
51
52
toFloat (StackInt n) = Just (fromIntegral n)
toFloat (StackSymbol s) = matches Just readable s
toFloat (StackExtra (Opaque (F f))) = Just f
toFloat x = Nothing
53

54
55
56
57
58
59
60
pattern StackFloat f <- (toFloat -> Just f)
pattern StackVect v = StackExtra (Opaque (V v))
pattern StackMat m = StackExtra (Opaque (M m))

data LogosData = F GL.GLfloat
               | V (V4 GL.GLfloat)
               | M (Mat Four Four GL.GLfloat)
61
62
               | Mesh GL.PrimitiveMode Int [(GL.AttribLocation,Int,GL.BufferObject)]
               | Uni GL.UniformLocation
63
               | TI GL.TextureObject
64
65
               deriving Show
data LogosState = LogosState {
66
67
  _running :: Bool,
  _wordChannel :: Chan String
68
69
70
  }
running :: Lens' LogosState Bool
running = lens _running (\x y -> x { _running = y })
71
72
wordChannel :: Lens' LogosState (Chan String)
wordChannel = lens _wordChannel (\x y -> x { _wordChannel = y })
73

74
dict = fromAList $
75
  (".",StackProg []):
76
77
78
79
80
81
82
83
84
85
  map (second StackBuiltin)
  [("wait"        , Builtin_Extra Wait  ),
   ("quit"        , Builtin_Extra Quit  ),
   ("format"      , Builtin_Extra Format),
   ("vcons"       , Builtin_Extra VCons),
   ("mcons"       , Builtin_Extra MCons),
   ("rotation"    , Builtin_Extra Rotation),
   ("translation" , Builtin_Extra Translation),
   ("**"          , Builtin_Extra MCompose),
   ("++"          , Builtin_Extra MAdd),
86
   ("transpose"   , Builtin_Extra Transpose),
87
88
89
90
91
92
93
   ("skew"        , Builtin_Extra Skew),
   ("ejection"    , Builtin_Extra Ejection),
   ("print"       , Builtin_Extra Print),
   ("window"      , Builtin_Extra OpenWindow),
   ("texture"     , Builtin_Extra Texture),
   ("mesh"        , Builtin_Extra BuildMesh),
   ("draw"        , Builtin_Extra Draw),
94
95
96
97
98
   ("uniform"     , Builtin_Extra Uniform),
   ("defuniform"     , Builtin_Extra DefUniform),
   ("norm"        , Builtin_Extra Norm),
   ("recip"        , Builtin_Extra Recip),
    
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
   ("def"        , Builtin_Def         ),
   ("$"          , Builtin_DeRef       ),
   ("lookup"     , Builtin_Lookup      ),
   ("exec"       , Builtin_Exec        ),
   ("quote"      , Builtin_Quote       ),
   
   ("stack"      , Builtin_Stack       ),
   ("clear"      , Builtin_Clear       ),
   ("shift"      , Builtin_Shift       ),
   ("shaft"      , Builtin_Shaft       ),
   ("pop"        , Builtin_Pop         ),
   ("popn"       , Builtin_PopN        ),
   ("dup"        , Builtin_Dup         ),
   ("dupn"       , Builtin_DupN        ),
   ("swap"       , Builtin_Swap        ),
   ("swapn"      , Builtin_SwapN       ),
   ("pick"       , Builtin_Pick        ),
   
   ("["          , Builtin_ListBegin   ),
   ("]"          , Builtin_ListEnd     ),
   
   ("+"          , Builtin_Add         ),
   ("-"          , Builtin_Sub         ),
   ("*"          , Builtin_Mul         ),
   ("div"        , Builtin_Div         ),
   ("mod"        , Builtin_Mod         ),
   ("sign"       , Builtin_Sign        ),
   
   ("each"       , Builtin_Each        ),
   ("range"      , Builtin_Range       ),
   
   ("vocabulary" , Builtin_CurrentDict ),
   ("empty"      , Builtin_Empty       ),
   ("insert"     , Builtin_Insert      ),
   ("delete"     , Builtin_Delete      ),
   ("keys"       , Builtin_Keys        )]

136
fromStack (StackSymbol x) = read x :: GL.GLfloat
137
138
139
140
141
142
143
144
145
146
147
fromStack (StackInt n) = fromIntegral n
fromStack _ = undefined

runLogos Wait = do
  st <- runStackState get
  case st of
    StackInt n:st' -> do
      liftIO $ threadDelay n
      runStackState $ put st'
    _ -> unit
runLogos Quit = runExtraState $ do running =- False
148
149
150
151
152
153
154
runLogos VCons = runStackState $ modify $ \case
  StackFloat w:StackFloat z:StackFloat y:StackFloat x:st -> StackVect (V4 x y z w):st
  st -> st
runLogos MCons = runStackState $ modify $ \case
  StackVect w:StackVect z:StackVect y:StackVect x:st -> StackMat (V4 x y z w):st
  st -> st
runLogos Rotation = runStackState $ modify $ \case
155
  StackVect u:StackVect v:st -> StackMat (rotation u v):st
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
  st -> st
runLogos Translation = runStackState $ modify $ \case
  StackVect (V4 x y z _):st -> StackMat (translation (V3 x y z)):st
  st -> st
runLogos Ejection = runStackState $ modify $ \case
  StackVect v:st -> StackMat (ejection v):st
  st -> st
runLogos Skew = runStackState $ modify $ \case
  StackVect v:st -> StackMat (skew v):st
  st -> st
runLogos MAdd = runStackState $ modify $ \case
  StackMat m:StackMat m':st -> StackMat (m+m'):st
  StackVect v:StackVect v':st -> StackVect (v+v'):st
  StackFloat f:StackFloat f':st -> StackExtra (Opaque $ F $ f+f'):st
  st -> st
runLogos MCompose = runStackState $ modify $ \case
  StackMat m':StackMat m:st -> StackMat (m'$*m):st
  StackMat m:StackVect v:st -> StackVect (v & from scalar %~ ($*m)):st
  StackVect v:StackMat m:st -> StackVect (v & from scalar %~ ($*m)):st
  StackVect v:StackVect v':st -> StackExtra (Opaque $ F $ scalProd v v'):st
  StackFloat f:StackVect v:st -> StackVect (pure f * v):st
  StackVect v:StackFloat f:st -> StackVect (pure f * v):st
  StackFloat f:StackMat m:st -> StackMat (map2 (f*) m):st
  StackMat m:StackFloat f:st -> StackMat (map2 (f*) m):st
180
181
182
183
  StackFloat f:StackFloat f':st -> StackExtra (Opaque $ F $ f*f'):st
  st -> st
runLogos Transpose = runStackState $ modify $ \case
  StackMat m:st -> StackMat (transpose m):st
184
  st -> st
185
186
187
188
189
190
191
192
runLogos Norm = runStackState $ modify $ \case
  StackVect v:st -> StackExtra (Opaque (F (sqrt $ scalProd v v))):st
  StackFloat v:st -> StackExtra (Opaque (F (abs v))):st
  st -> st
runLogos Recip = runStackState $ modify $ \case
  StackFloat f:st -> StackExtra (Opaque $ F $ recip f):st
  st -> st
  
193
194
195
196
197
198
199
200
201
runLogos Format = do
  st <- runStackState get
  case st of
    StackSymbol str:st' -> do
      let format ('%':'s':xs) (h:t) = second (showV h+) $ format xs t
          format (x:xs) l = second (x:) $ format xs l
          format _ st' = (st',"")
          showV (StackExtra (Opaque x)) = show x
          showV (StackList l) = "["+intercalate "," (map showV l)+"]"
202
          showV (StackSymbol s) = s
203
204
205
206
207
208
209
210
211
212
213
214
215
216
          showV x = show x
          (st'',msg) = format str st'
      runStackState $ put (StackSymbol msg:st'')
    _ -> unit
runLogos Print = do
  st <- runStackState get
  case st of
    StackSymbol str:st' -> liftIO (putStr str) >> runStackState (put st')
    _ -> unit
runLogos OpenWindow = do
  st <- runStackState get
  case st of
    StackInt h:StackInt w:st' -> do
      runStackState $ put st'
217
      wc <- runExtraState $ getl wordChannel
218
219
220
221
222
223
224
      void $ liftIO $ do
        GLFW.openWindowHint GLFW.FSAASamples 4
        GLFW.openWindowHint GLFW.OpenGLVersionMajor 3
        GLFW.openWindowHint GLFW.OpenGLVersionMinor 3
        GLFW.openWindowHint GLFW.OpenGLProfile GLFW.OpenGLCoreProfile
 
        success <- GLFW.openWindow (GL.Size (fromIntegral w) (fromIntegral h)) [GLFW.DisplayRGBBits 8 8 8, GLFW.DisplayAlphaBits 8, GLFW.DisplayDepthBits 8] GLFW.Window
225
226
227
228
229
230
231
232
233
        if not success then throw $ SomeException GLFWWindowOpenException else do
          initGL >> initShaders
          forkIO $ forever $ GLFW.pollEvents >> threadDelay 50000
          GLFW.keyCallback $= \k ev -> do
            putStrLn $ "Key : "+show (k,ev)
            writeChan wc $ "'"+case k of GLFW.CharKey c -> [c] ; GLFW.SpecialKey s -> show s
            writeChan wc $ "'"+case ev of GLFW.Press -> "press" ; GLFW.Release -> "release"
            writeChan wc $ "onkey"

234
    _ -> unit
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
runLogos Uniform = do
  st <- runStackState get
  case st of
    StackSymbol name:st' -> do
      i <- liftIO $ do
        Just p <- SV.get GL.currentProgram
        SV.get (GL.uniformLocation p name)
      runStackState $ put (StackExtra (Opaque (Uni i)):st')
    _ -> unit
runLogos DefUniform = do
  st <- runStackState get
  case st of
    x:StackExtra (Opaque (Uni u)):st' -> do
      runStackState $ put st'
      case x of
        StackVect (V4 x y z w) -> liftIO $ GL.uniform u $= GL.Vector4 x y z w
251
        StackMat m -> liftIO $ setUniformMat u m
252
253
254
        _ -> unit
    _ -> unit
      
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
runLogos Texture = do
  st <- runStackState get
  case st of
    StackSymbol file:StackSymbol name:st' -> do
      runStackState (put st')
      textureLoaded <- liftIO $ do
        imgbytes <- readChunk file
        let img = convertRGB8 <$> decodeImage imgbytes
        tex@(GL.TextureObject texi) <- GL.genObjectName
        case img of
          Right (Image w h imgd) -> do
            GL.activeTexture $= GL.TextureUnit texi
            GL.textureBinding GL.Texture2D $= Just tex
            V.unsafeWith imgd $ \imgp -> do
              GL.texImage2D GL.Texture2D GL.NoProxy 0 GL.RGBA8 (GL.TextureSize2D (fromIntegral w) (fromIntegral h)) 0 (GL.PixelData GL.RGB GL.UnsignedByte imgp)
            GL.textureFilter GL.Texture2D $= ((GL.Linear',Nothing),GL.Linear')
            GL.generateMipmap' GL.Texture2D
            Just prog <- SV.get GL.currentProgram
            ul <- GL.uniformLocation prog name
274
            GL.uniform ul $= GL.TextureUnit texi
275
276
277
278
279
280
281
282
283
284
            return $ Just tex
          Left err -> do
            putStrLn err
            return Nothing
      case textureLoaded of
        Just tex -> runStackState $ modify (StackExtra (Opaque (TI tex)):)
        Nothing -> unit

    _ -> unit

285
runLogos BuildMesh = do
286
287
  st <- runStackState get
  case st of
288
289
    StackSymbol s:StackList attribs:StackList props:st' -> do
      m <- liftIO $ do
290
        let mode = case s of
291
292
293
              "LINES" -> GL.Lines
              "TRIANGLES" -> GL.Triangles
              "POINTS" -> GL.Points
294
              _ -> GL.Points
295
296
            fullVertices = deZip $ traverse Zip [[v | StackVect v <- vs] | StackList vs <- props]
            newVec f l = GL.genObjectName <*= \vb -> do
297
298
              let vs = V.unfoldr (\case
                                     h:t -> Just (f h,t)
299
                                     [] -> Nothing) l
300
301
302
              GL.bindBuffer GL.ArrayBuffer $= Just vb
              V.unsafeWith vs $ \p -> do
                GL.bufferData GL.ArrayBuffer $= (fromIntegral (V.length vs * sizeOf (vs V.! 0)),p,GL.StaticDraw)
303
        Just prog <- SV.get GL.currentProgram
304
305
306
307
308
309
        vecs <- sequence (zap [let run = case n of
                                     1 -> newVec (\(V4 x _ _ _) -> V1 x)
                                     2 -> newVec (\(V4 x y _ _) -> V2 x y)
                                     3 -> newVec (\(V4 x y z _) -> V3 x y z)
                                     4 -> newVec id
                                     _ -> error $ "Invalid attribute size "+show n+" (must be between 1 and 4)"
310
311
312
                               in \l -> do
                                  loc <- SV.get (GL.attribLocation prog s)
                                  run l <&> (loc,n,)
313
314
315
316
317
318
319
                              | StackList [StackSymbol s,StackInt n] <- attribs] fullVertices)
        return (Mesh mode (length (head fullVertices)) vecs)
      runStackState $ put (StackExtra (Opaque m):st')
    _ -> unit
      
runLogos Draw = do
  st <- runStackState get
320
321
322
323
324
325
326
327
  let withAttrib (l,sz,vec) go = between (GL.vertexAttribArray l $= GL.Enabled) (GL.vertexAttribArray l $= GL.Disabled) $ do
        GL.bindBuffer GL.ArrayBuffer $= Just vec
        GL.vertexAttribPointer l $= (GL.ToFloat, GL.VertexArrayDescriptor (fromIntegral sz) GL.Float 0 nullPtr)
        go
      drawElt (StackExtra (Opaque (Mesh mode size vecs))) = drawMesh mode size vecs
      drawElt (StackList [StackExtra (Opaque (Uni u)), StackMat m]) = setUniformMat u m
      drawElt (StackList l) = for_ l drawElt
      drawElt _ = unit
328

329
330
331
332
333
      drawMesh mode size vecs = composing withAttrib vecs $ do
        GL.drawArrays mode 0 (fromIntegral size)
      doDraw go = do
        runStackState (modify $ drop 1)
        liftIO $ between (GL.clear [ GL.DepthBuffer, GL.ColorBuffer ]) GLFW.swapBuffers go
334
        
335
336
  case st of
    x:_ -> doDraw (drawElt x)
337
338
    _ -> unit

339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
data GLSLCompileException = GLSLShaderCompileError String | GLSLProgramLinkError String
  deriving (Show,Generic)
instance Exception GLSLCompileException
data GLFWException = GLFWWindowOpenException
  deriving (Show,Generic)
instance Exception GLFWException

initShaders = GL.createProgram <*= \prog -> do
  let compileShader shType shFile = GL.createShader shType <*= \vs -> do
        body <- readChunk shFile
        GL.shaderSourceBS vs $= body
        GL.compileShader vs
        success <- SV.get (GL.compileStatus vs)
        if success then
          GL.attachShader prog vs
          else throw . SomeException . GLSLShaderCompileError =<< SV.get (GL.shaderInfoLog vs)
  compileShader GL.VertexShader "vertex.shader"
  compileShader GL.FragmentShader "fragment.shader"
  
  GL.linkProgram prog
  success <- SV.get (GL.linkStatus prog)
  if success then 
    GL.currentProgram $= Just prog
    else
    throw . SomeException . GLSLProgramLinkError =<< SV.get (GL.programInfoLog prog)

initGL = do
  vao <- GL.genObjectName
  GL.bindVertexArrayObject $= Just vao
  
  GL.depthFunc            $= Just GL.Lequal
  GL.blend                $= GL.Enabled
  GL.blendFunc            $= (GL.SrcAlpha, GL.OneMinusSrcAlpha)
  GL.texture GL.Texture2D $= GL.Enabled
  GL.textureFunction      $= GL.Blend

375
376
377
378
379
main = between (void GLFW.initialize) GLFW.terminate $ do
  isTerm <- hIsTerminalDevice stdin
  args <- getArgs
  prelude <- fold <$> for args readString
  symList <- newIORef (keys (c'map dict))
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
  wordChan <- newChan
  
  tid <- forkIO $ do
    let getAll = unsafeInterleaveIO $ do
          ln <- readline "Logos> " 
          lns <- getAll
          case ln of
            Just x -> do addHistory x; return $ x + " .\n" + lns
            Nothing -> putStr "\n" >> return ""
    setCompletionEntryFunction $ Just $ \line -> do
      sl <- readIORef symList
      case reverse (words (line+"?")) of
        "?":_ -> return sl
        wp:_ -> let wps = length wp-1; wp' = init wp in return [w | w <- sl, take wps w==wp']
        _ -> return []
  
    text <- if isTerm then getAll else unsafeInterleaveIO $ readHString stdin
    for_ (stringWords (prelude + " " + text)) (writeChan wordChan)
    
  let go = do
        w <- liftIO $ readChan wordChan
401
402
403
        execSymbol runLogos (\_ -> unit) w
        runDictState get >>= \d -> liftIO (writeIORef symList (keys d))
        r <- runExtraState $ getl running
404
405
406
        if r then go else unit
  (go^..stateT.concatT) (defaultState dict (LogosState True wordChan))
  killThread tid
407

408
409
410
411
412
413
414
415
416
417
418
instance Storable (Vec Zero a) where
  sizeOf _ = zero
  alignment _ = 1
  peek p = return V0
  poke _ _ = unit
instance (Storable a,Storable (Vec n a)) => Storable (Vec (Succ n) a) where
  sizeOf ~(VS x v) = sizeOf x + sizeOf v
  alignment ~(VS x v) = alignment x
  peek p = peek (castPtr p) <&> uncurry VS
  poke p (VS x v) = poke (castPtr p) (x,v)

419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
instance (Storable a,Storable b) => Storable (a,b) where
  sizeOf x = sizeOf (fst x) + sizeOf (snd x)
  alignment x = lcm (alignment (fst x)) (alignment (snd x))
  peek p = do
    x <- peek (castPtr p)
    y <- peek (castPtr $ p`plusPtr`sizeOf x)
    return (x,y)
  poke p (x,y) = do
    poke (castPtr p) x
    poke (castPtr $ p`plusPtr`sizeOf x) y
instance (Storable a,Storable b,Storable c) => Storable (a,b,c) where
  sizeOf ~(x,y,z) = sizeOf (x,(y,z))
  alignment ~(x,y,z) = alignment (x,(y,z))
  peek p = peek (castPtr p) <&> \(x,(y,z)) -> (x,y,z)
  poke p (x,y,z) = poke (castPtr p) (x,(y,z))
instance (Storable a,Storable b,Storable c,Storable d) => Storable (a,b,c,d) where
  sizeOf ~(x,y,z,u) = sizeOf (x,(y,z,u))
  alignment ~(x,y,z,u) = alignment (x,(y,z,u))
  peek p = peek (castPtr p) <&> \(x,(y,z,u)) -> (x,y,z,u)
  poke p (x,y,z,u) = poke (castPtr p) (x,(y,z,u))
instance (Storable a,Storable b,Storable c,Storable d,Storable e) => Storable (a,b,c,d,e) where
  sizeOf ~(x,y,z,u,v) = sizeOf (x,(y,z,u,v))
  alignment ~(x,y,z,u,v) = alignment (x,(y,z,u,v))
  peek p = peek (castPtr p) <&> \(x,(y,z,u,v)) -> (x,y,z,u,v)
  poke p (x,y,z,u,v) = poke (castPtr p) (x,(y,z,u,v))