123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195 |
- {-- T.hs - some imperative opengl mess
- -- Copyright (C) 2018-2019 caryoscelus
- --
- -- This program is free software: you can redistribute it and/or modify
- -- it under the terms of the GNU General Public License as published by
- -- the Free Software Foundation, either version 3 of the License, or
- -- (at your option) any later version.
- --
- -- This program is distributed in the hope that it will be useful,
- -- but WITHOUT ANY WARRANTY; without even the implied warranty of
- -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- -- GNU General Public License for more details.
- --
- -- You should have received a copy of the GNU General Public License
- -- along with this program. If not, see <http://www.gnu.org/licenses/>.
- --}
- {-# LANGUAGE
- NoMonomorphismRestriction,
- TemplateHaskell,
- ScopedTypeVariables,
- TypeFamilies,
- LambdaCase,
- GADTs,
- FlexibleContexts
- #-}
- module T where
- import Debug.Trace (traceShowId)
- import Data.Maybe
- import Data.Word (Word32)
- import Graphics.GPipe
- import qualified Graphics.GPipe.Context.GLFW as GLFW
- import Data.IORef
- import Control.Monad.IO.Class
- import Control.Monad
- import Control.Monad.Exception (MonadException)
- import Control.Category ((>>>))
- import Data.Label
- import GL
- import Util
- import Strokes
- -- for agda
- inductionOnIntAsNat :: a -> (a -> a) -> Int -> a
- inductionOnIntAsNat z f n | n <= 0 = z
- inductionOnIntAsNat z f n = f (inductionOnIntAsNat z f (pred n))
- avg x y = (x + y) `div` 2
- zoomStep = 32
- toZoom to from = 2 ** (fromIntegral (to - from) / zoomStep - 8)
- drawLine :: Double -> Point -> Point -> [V2 Float]
- drawLine _ a b | a == b = []
- drawLine q a' b' =
- let
- tt = realToFrac . (* q) . fromIntegral
- toQ = \(V2 x y) -> V2 (tt x) (tt y)
- a = toQ a'
- b = toQ b'
- dt = perp (signorm (a - b)) / 256
- in
- [ a-dt , a+dt
- , b+dt
- , a-dt
- , b-dt , b+dt
- ]
- wh = 512
- screenToGl :: Int -> Int -> Double -> Double -> V2 Coord
- screenToGl w h x y = V2
- (- fromIntegral w `div` 2 + floor x)
- (fromIntegral h `div` 2 - floor y)
- ratioToFloat :: Integer -> Integer -> Float
- ratioToFloat x y
- | y == 0 = 0 -- duh
- | otherwise = fromIntegral x / fromIntegral y
- v2to4 :: Num i => V2 i -> V4 i
- v2to4 (V2 x y) = V4 x y 0 1
- data GLRGBPoint = GLRGBPoint
- { glpoint :: V2 Float
- , glrgb :: V3 Float
- }
- -- type Triangles = [ GLRGBPoint ]
- data RenderResult app = RenderResult
- { newState :: app
- , result :: [ GLRGBPoint ]
- }
- data DrawApp app = DrawApp
- { emptyApp :: app
- , renderApp :: app -> RenderResult app
- , frameCount :: app -> Integer
- , nowFrame :: app -> Integer
- , isDirty :: Integer -> app -> Bool
- , dontClearTexture :: app -> app
- , getNeedToClearTexture :: app -> Bool
- , mouseCallback
- :: ((app -> app) -> IO ())
- -> GLFW.MouseButton -> GLFW.MouseButtonState -> GLFW.ModifierKeys
- -> IO ()
- , cursorCallback
- :: ((app -> app) -> IO ())
- -> Double -> Double
- -> IO ()
- , keyCallback
- :: ((app -> app) -> IO ())
- -> GLFW.Key -> Int -> GLFW.KeyState -> GLFW.ModifierKeys
- -> IO ()
- }
- glPointToV4 :: GLRGBPoint -> (V4 Float , V3 Float)
- glPointToV4 p = (v2to4 (glpoint p) , glrgb p)
- proceedRender drawApp app clearTex shader tex = do
- when (getNeedToClearTexture drawApp app) $ clearTex tex
- let
- app' = dontClearTexture drawApp app
- RenderResult newState lines = renderApp drawApp app
- lineBuff :: Buffer os (B4 Float, B3 Float) <- newBuffer (length lines)
- unless (null lines) $
- writeBuffer lineBuff 0 (fmap glPointToV4 lines)
- render $ do
- vertexArray <- newVertexArray lineBuff
- let brushTriangles = toPrimitiveArray TriangleList vertexArray
- img <- getTexture2DImage tex 0
- shader (OnTexture img brushTriangles)
- pure app'
- everything drawApp = runContextT GLFW.defaultHandleConfig $ do
- let
- void = minBound :: Word32
- clearTex t = do
- writeTexture2D t 0 0 (V2 wh wh) (repeat (V3 void void void))
- bgColor = V3 0.0 0.0 0.0
- allColors = V3 True True True
- wCfg = (GLFW.defaultWindowConfig "rainynite-linaer")
- { GLFW.configWidth = wh , GLFW.configHeight = wh }
- eApp = emptyApp drawApp
- app <- liftIO $ newIORef eApp
- frameTextures <-
- sequence . replicate (fromIntegral $ frameCount drawApp eApp) $ newTexture2D RGB8 (V2 wh wh) 1
- win <- newWindow (WindowFormatColor RGB8) wCfg
- brushTexShader <- compileShader (hsvTrianglesOnTextureShader wh wh)
- texShader <- compileShader (singleTextureOnWindowShader win wh wh)
- GLFW.setMouseButtonCallback win . pure $
- mouseCallback drawApp (modifyIORef app)
- GLFW.setCursorPosCallback win . pure $
- cursorCallback drawApp (modifyIORef app)
- GLFW.setKeyCallback win . pure $
- keyCallback drawApp (modifyIORef app)
-
- wholeScreenBuff :: Buffer os (B2 Float) <- newBuffer 4
- writeBuffer wholeScreenBuff 0
- [ V2 0 0
- , V2 0 1
- , V2 1 1
- , V2 1 0
- ]
- foreverTil (fromMaybe False <$> GLFW.windowShouldClose win) $ do
- appVal <- liftIO $ readIORef app
- fi <- liftIO $ nowFrame drawApp <$> readIORef app
- let nowTex = frameTextures !! fromIntegral fi
- appVal' <- proceedRender drawApp appVal clearTex brushTexShader nowTex
- liftIO $ writeIORef app appVal'
- -- put that onto window
- render $ do
- clearWindowColor win bgColor
- wholeScreen <- newVertexArray wholeScreenBuff
- let wholeScreenTriangles = toPrimitiveArray TriangleFan wholeScreen
- texShader (RenderTexture wholeScreenTriangles nowTex)
- swapWindowBuffers win
- pure ()
|