<commit_before>{-# LANGUAGE GADTs, TypeFamilies, TypeFamilyDependencies, TypeInType #-}
{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE ExplicitForAll, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, RankNTypes, UndecidableInstances #-}
{-# LANGUAGE LambdaCase, OverloadedStrings, PackageImports, PartialTypeSignatures, RecordWildCards, ScopedTypeVariables, TupleSections, TypeOperators #-}
{-# LANGUAGE UnicodeSyntax #-}
{-# OPTIONS_GHC -Weverything #-}
{-# OPTIONS_GHC -Wno-unticked-promoted-constructors -Wno-missing-import-lists -Wno-implicit-prelude #-}
{-# OPTIONS_GHC -Wno-monomorphism-restriction -Wno-name-shadowing #-}
{-# OPTIONS_GHC -Wno-unsafe -Wno-missing-export-lists #-}

module HoloPort where

-- Basis
import           HoloPrelude

-- Types
import qualified Data.Map.Strict                   as Map
import qualified Data.Set                          as Set
import qualified Data.Text                         as T
import qualified Data.Vector                       as V
import qualified Data.Vect                         as Vc
import           Data.Vect                                (Mat4(..), Vec3(..))

-- Algebra
import           Linear

-- Manually-bound Cairo
import qualified Graphics.Rendering.Cairo          as GRC
import qualified Graphics.Rendering.Cairo.Internal as GRCI

-- glib-introspection -based Cairo and Pango
import qualified GI.Cairo                          as GIC
import qualified GI.Pango                          as GIP

-- Dirty stuff
import qualified Control.Concurrent.STM            as STM
import qualified Data.Unique                       as U
import qualified Foreign.C.Types                   as F
import qualified Foreign                           as F
import qualified System.IO.Unsafe                  as IO
import qualified System.Mem.Weak                   as SMem

-- …
import           Graphics.GL.Core33                as GL
import "GLFW-b"  Graphics.UI.GLFW                  as GL

-- LambdaCube
import qualified LambdaCube.GL                     as GL
import qualified LambdaCube.GL.Mesh                as GL
import qualified LambdaCube.Linear                 as LCLin
import           LambdaCube.Mesh                   as LC

-- LambdaCube Quake III
import           GameEngine.Utils                  as Q3

-- Local imports
import           Flatland
import           HoloCairo
import           HoloCube
import           HoloFont



-- * Drawable state support
--
newtype IdToken = IdToken { fromIdToken ∷ U.Unique } deriving (Eq, Ord)

newId ∷ (MonadIO m) ⇒ m IdToken
newId = liftIO $
  IdToken <$> U.newUnique

blankIdToken ∷ IdToken
blankIdToken = IO.unsafePerformIO newId



-- * Impure IO-stateful map
data IOMap k v where
  IOMap ∷ Ord k ⇒
    { iomap ∷ STM.TVar (Map.Map k v)
    } → IOMap k v

newtype DrawableTracker = DrawableTracker { fromDT ∷ IOMap IdToken Drawable }

mkIOMap ∷ (MonadIO m, Ord k) ⇒ m (IOMap k v)
mkIOMap = IOMap
  <$> (liftIO $ STM.newTVarIO $ Map.empty)

iomapAccess ∷ (MonadIO m) ⇒ IOMap k v → m (Map.Map k v)
iomapAccess IOMap{..} = liftIO $ STM.readTVarIO iomap

iomapAdd ∷ (MonadIO m, Ord k) ⇒ IOMap k v → k → v → m ()
iomapAdd IOMap{..} k v = liftIO $ do
  STM.atomically $ STM.modifyTVar' iomap (Map.insert k v)
  pure ()

iomapDrop ∷ (MonadIO m, Ord k) ⇒ IOMap k v → k → m ()
iomapDrop IOMap{..} x = liftIO $
  STM.atomically $ STM.modifyTVar' iomap (Map.delete x)

iomapHas ∷ (MonadIO m, Ord k) ⇒ IOMap k v → k → m Bool
iomapHas iomap x = Map.member x <$> iomapAccess iomap



-- | Usher Cairo + Pango -enabled surfaces onto a GL Window,
--   according to user-controlled Settings.
data Port where
  Port ∷
    { portSettings        ∷ Settings
    , portFontmap         ∷ FontMap PU
    , portWindow          ∷ GL.Window
    , portObjectStream    ∷ ObjectStream
    , portRenderer        ∷ Renderer
    , portEmptyDrawable   ∷ Drawable
    , portDrawableTracker ∷ DrawableTracker
    } → Port

portDΠ ∷ Port → DΠ
portDΠ = sttsDΠ ∘ portSettings

portCreate  ∷ (MonadIO m) ⇒ GL.Window → Settings → m (Port)
portCreate portWindow portSettings@Settings{..} = do
  portFontmap                      ← makeFontMap sttsDΠ fmDefault sttsFontPreferences
  liftIO $ putStrLn $ printf "%s" (show portFontmap)
  (portRenderer, portObjectStream) ← makeSimpleRenderedStream portWindow (("portStream", "portMtl") ∷ (ObjArrayNameS, UniformNameS))
  rendererDrawFrame portRenderer
  portEmptyDrawable ← makeDrawable portObjectStream (di 1 1)
  portDrawableTracker@(DrawableTracker dt) ← DrawableTracker <$> mkIOMap
  iomapAdd dt blankIdToken portEmptyDrawable
  pure Port{..}

portUpdateSettings ∷ (MonadIO m) ⇒ Port → Settings → m (Port)
portUpdateSettings port portSettings = do
  pure $ port { portSettings = portSettings }

portNextFrame ∷ (MonadIO m) ⇒ Port → m Frame
portNextFrame Port{..} = do
  rendererDrawFrame  portRenderer
  rendererSetupFrame portRenderer

portFont  ∷ Port → FontKey → Maybe (Font Found PU)
portFont Port{..} = lookupFont portFontmap

portFont' ∷ Port → FontKey → Font Found PU
portFont' po fk = portFont po fk
  & fromMaybe (errorMissingFontkey fk)



data Settings where
  Settings ∷
    { sttsDΠ              ∷ DΠ
    , sttsFontPreferences ∷ FontPreferences PU
    } → Settings
    deriving (Eq, Show)

defaultSettings ∷ (MonadIO m) ⇒ m Settings
defaultSettings = do
  let sttsDΠ ∷ DΠ         = 96
      sttsFontPreferences = FontPreferences
        [ ("default",     Left $ Alias "defaultMono" )
        , ("defaultSans", Right $ [ FontSpec "Bitstream Charter" "Regular" $ FSROutline (PUs 16) ])
        , ("defaultMono", Right $ [ FontSpec "Terminus"          "Regular" $ FSRBitmap  (PUs 15) LT ])
        ]
  pure Settings{..}



-- | A Pango/Cairo-capable 'Drawable' to display in a qPort.
data Drawable where
  Drawable ∷
    { dObjectStream ∷ ObjectStream
    , dDi           ∷ Di Int
    , dSurface      ∷ GRCI.Surface
    , dSurfaceData  ∷ (F.Ptr F.CUChar, (Int, Int))
    , dCairo        ∷ Cairo
    , dGIC          ∷ GIC.Context
    --
    , dMesh         ∷ LC.Mesh
    , dGPUMesh      ∷ GL.GPUMesh
    , dGLObject     ∷ GL.Object
    , dTexId        ∷ GLuint
    } → Drawable

imageSurfaceGetPixels' :: GRC.Surface → IO (F.Ptr F.CUChar, (Int, Int))
imageSurfaceGetPixels' pb = do
  pixPtr ← GRCI.imageSurfaceGetData pb
  when (pixPtr ≡ F.nullPtr) $ do
    fail "imageSurfaceGetPixels: image surface not available"
  h ← GRC.imageSurfaceGetHeight pb
  r ← GRC.imageSurfaceGetStride pb
  return (pixPtr, (r, h))

portMakeDrawable ∷ (MonadIO m) ⇒ Port → Di Double → m Drawable
portMakeDrawable Port{..} = makeDrawable portObjectStream

makeDrawable ∷ (MonadIO m) ⇒ ObjectStream → Di Double → m Drawable
makeDrawable dObjectStream@ObjectStream{..} dDi' = liftIO $ do
  let dDi@(Di (V2 w h)) = fmap ceiling dDi'
  dSurface      ← GRC.createImageSurface GRC.FormatARGB32 w h
  dCairo        ← cairoCreate  dSurface
  dGIC          ← cairoToGICairo dCairo

  let (dx, dy) = (fromIntegral w, fromIntegral $ -h)
      -- position = V.fromList [ LCLin.V3  0 dy 0, LCLin.V3  0  0 0, LCLin.V3 dx  0 0, LCLin.V3  0 dy 0, LCLin.V3 dx  0 0, LCLin.V3 dx dy 0 ]
      position = V.fromList [ LCLin.V2  0 dy,   LCLin.V2  0  0,   LCLin.V2 dx  0,   LCLin.V2  0 dy,   LCLin.V2 dx  0,   LCLin.V2 dx dy ]
      texcoord = V.fromList [ LCLin.V2  0  1,   LCLin.V2  0  0,   LCLin.V2  1  0,   LCLin.V2  0  1,   LCLin.V2  1  0,   LCLin.V2  1  1 ]
      dMesh    = LC.Mesh { mPrimitive  = P_Triangles
                         , mAttributes = Map.fromList [ ("position",  A_V2F position)
                                                      , ("uv",        A_V2F texcoord) ] }
  dGPUMesh      ← GL.uploadMeshToGPU dMesh
  SMem.addFinalizer dGPUMesh $
    GL.disposeMesh dGPUMesh
  dGLObject     ← GL.addMeshToObjectArray osStorage (fromOANS osObjArray) [unameStr osUniform, "viewProj"] dGPUMesh

  dSurfaceData  ← imageSurfaceGetPixels' dSurface
  dTexId        ← F.alloca $! \pto → glGenTextures 1 pto >> F.peek pto

  -- dTexture      ← uploadTexture2DToGPU'''' False False False False $ (fromWi dStridePixels, h, GL_BGRA, pixels)
  pure Drawable{..}

disposeDrawable ∷ (MonadIO m) ⇒ ObjectStream → Drawable → m ()
disposeDrawable ObjectStream{..} Drawable{..} = liftIO $ do
  -- see experiment in LCstress
  F.withArray [dTexId] $ glDeleteTextures 1 -- release tex id
  GL.removeObject osStorage dGLObject
  GL.disposeMesh  dGPUMesh
  -- cairoCreate is auto-managed
  GRCI.surfaceFinish dSurface -- undo createImageSurface<commit_msg>HoloPort:  trade a heap corruption for a memory leak<commit_after>{-# LANGUAGE GADTs, TypeFamilies, TypeFamilyDependencies, TypeInType #-}
{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE ExplicitForAll, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, RankNTypes, UndecidableInstances #-}
{-# LANGUAGE LambdaCase, OverloadedStrings, PackageImports, PartialTypeSignatures, RecordWildCards, ScopedTypeVariables, TupleSections, TypeOperators #-}
{-# LANGUAGE UnicodeSyntax #-}
{-# OPTIONS_GHC -Weverything #-}
{-# OPTIONS_GHC -Wno-unticked-promoted-constructors -Wno-missing-import-lists -Wno-implicit-prelude #-}
{-# OPTIONS_GHC -Wno-monomorphism-restriction -Wno-name-shadowing #-}
{-# OPTIONS_GHC -Wno-unsafe -Wno-missing-export-lists #-}

module HoloPort where

-- Basis
import           HoloPrelude

-- Types
import qualified Data.Map.Strict                   as Map
import qualified Data.Set                          as Set
import qualified Data.Text                         as T
import qualified Data.Vector                       as V
import qualified Data.Vect                         as Vc
import           Data.Vect                                (Mat4(..), Vec3(..))

-- Algebra
import           Linear

-- Manually-bound Cairo
import qualified Graphics.Rendering.Cairo          as GRC
import qualified Graphics.Rendering.Cairo.Internal as GRCI

-- glib-introspection -based Cairo and Pango
import qualified GI.Cairo                          as GIC
import qualified GI.Pango                          as GIP

-- Dirty stuff
import qualified Control.Concurrent.STM            as STM
import qualified Data.Unique                       as U
import qualified Foreign.C.Types                   as F
import qualified Foreign                           as F
import qualified System.IO.Unsafe                  as IO
import qualified System.Mem.Weak                   as SMem

-- …
import           Graphics.GL.Core33                as GL
import "GLFW-b"  Graphics.UI.GLFW                  as GL

-- LambdaCube
import qualified LambdaCube.GL                     as GL
import qualified LambdaCube.GL.Mesh                as GL
import qualified LambdaCube.Linear                 as LCLin
import           LambdaCube.Mesh                   as LC

-- LambdaCube Quake III
import           GameEngine.Utils                  as Q3

-- Local imports
import           Flatland
import           HoloCairo
import           HoloCube
import           HoloFont



-- * Drawable state support
--
newtype IdToken = IdToken { fromIdToken ∷ U.Unique } deriving (Eq, Ord)

newId ∷ (MonadIO m) ⇒ m IdToken
newId = liftIO $
  IdToken <$> U.newUnique

blankIdToken ∷ IdToken
blankIdToken = IO.unsafePerformIO newId



-- * Impure IO-stateful map
data IOMap k v where
  IOMap ∷ Ord k ⇒
    { iomap ∷ STM.TVar (Map.Map k v)
    } → IOMap k v

newtype DrawableTracker = DrawableTracker { fromDT ∷ IOMap IdToken Drawable }

mkIOMap ∷ (MonadIO m, Ord k) ⇒ m (IOMap k v)
mkIOMap = IOMap
  <$> (liftIO $ STM.newTVarIO $ Map.empty)

iomapAccess ∷ (MonadIO m) ⇒ IOMap k v → m (Map.Map k v)
iomapAccess IOMap{..} = liftIO $ STM.readTVarIO iomap

iomapAdd ∷ (MonadIO m, Ord k) ⇒ IOMap k v → k → v → m ()
iomapAdd IOMap{..} k v = liftIO $ do
  STM.atomically $ STM.modifyTVar' iomap (Map.insert k v)
  pure ()

iomapDrop ∷ (MonadIO m, Ord k) ⇒ IOMap k v → k → m ()
iomapDrop IOMap{..} x = liftIO $
  STM.atomically $ STM.modifyTVar' iomap (Map.delete x)

iomapHas ∷ (MonadIO m, Ord k) ⇒ IOMap k v → k → m Bool
iomapHas iomap x = Map.member x <$> iomapAccess iomap



-- | Usher Cairo + Pango -enabled surfaces onto a GL Window,
--   according to user-controlled Settings.
data Port where
  Port ∷
    { portSettings        ∷ Settings
    , portFontmap         ∷ FontMap PU
    , portWindow          ∷ GL.Window
    , portObjectStream    ∷ ObjectStream
    , portRenderer        ∷ Renderer
    , portEmptyDrawable   ∷ Drawable
    , portDrawableTracker ∷ DrawableTracker
    } → Port

portDΠ ∷ Port → DΠ
portDΠ = sttsDΠ ∘ portSettings

portCreate  ∷ (MonadIO m) ⇒ GL.Window → Settings → m (Port)
portCreate portWindow portSettings@Settings{..} = do
  portFontmap                      ← makeFontMap sttsDΠ fmDefault sttsFontPreferences
  liftIO $ putStrLn $ printf "%s" (show portFontmap)
  (portRenderer, portObjectStream) ← makeSimpleRenderedStream portWindow (("portStream", "portMtl") ∷ (ObjArrayNameS, UniformNameS))
  rendererDrawFrame portRenderer
  portEmptyDrawable ← makeDrawable portObjectStream (di 1 1)
  portDrawableTracker@(DrawableTracker dt) ← DrawableTracker <$> mkIOMap
  iomapAdd dt blankIdToken portEmptyDrawable
  pure Port{..}

portUpdateSettings ∷ (MonadIO m) ⇒ Port → Settings → m (Port)
portUpdateSettings port portSettings = do
  pure $ port { portSettings = portSettings }

portNextFrame ∷ (MonadIO m) ⇒ Port → m Frame
portNextFrame Port{..} = do
  rendererDrawFrame  portRenderer
  rendererSetupFrame portRenderer

portFont  ∷ Port → FontKey → Maybe (Font Found PU)
portFont Port{..} = lookupFont portFontmap

portFont' ∷ Port → FontKey → Font Found PU
portFont' po fk = portFont po fk
  & fromMaybe (errorMissingFontkey fk)



data Settings where
  Settings ∷
    { sttsDΠ              ∷ DΠ
    , sttsFontPreferences ∷ FontPreferences PU
    } → Settings
    deriving (Eq, Show)

defaultSettings ∷ (MonadIO m) ⇒ m Settings
defaultSettings = do
  let sttsDΠ ∷ DΠ         = 96
      sttsFontPreferences = FontPreferences
        [ ("default",     Left $ Alias "defaultMono" )
        , ("defaultSans", Right $ [ FontSpec "Bitstream Charter" "Regular" $ FSROutline (PUs 16) ])
        , ("defaultMono", Right $ [ FontSpec "Terminus"          "Regular" $ FSRBitmap  (PUs 15) LT ])
        ]
  pure Settings{..}



-- | A Pango/Cairo-capable 'Drawable' to display in a qPort.
data Drawable where
  Drawable ∷
    { dObjectStream ∷ ObjectStream
    , dDi           ∷ Di Int
    , dSurface      ∷ GRCI.Surface
    , dSurfaceData  ∷ (F.Ptr F.CUChar, (Int, Int))
    , dCairo        ∷ Cairo
    , dGIC          ∷ GIC.Context
    --
    , dMesh         ∷ LC.Mesh
    , dGPUMesh      ∷ GL.GPUMesh
    , dGLObject     ∷ GL.Object
    , dTexId        ∷ GLuint
    } → Drawable

imageSurfaceGetPixels' :: GRC.Surface → IO (F.Ptr F.CUChar, (Int, Int))
imageSurfaceGetPixels' pb = do
  pixPtr ← GRCI.imageSurfaceGetData pb
  when (pixPtr ≡ F.nullPtr) $ do
    fail "imageSurfaceGetPixels: image surface not available"
  h ← GRC.imageSurfaceGetHeight pb
  r ← GRC.imageSurfaceGetStride pb
  return (pixPtr, (r, h))

portMakeDrawable ∷ (MonadIO m) ⇒ Port → Di Double → m Drawable
portMakeDrawable Port{..} = makeDrawable portObjectStream

makeDrawable ∷ (MonadIO m) ⇒ ObjectStream → Di Double → m Drawable
makeDrawable dObjectStream@ObjectStream{..} dDi' = liftIO $ do
  let dDi@(Di (V2 w h)) = fmap ceiling dDi'
  dSurface      ← GRC.createImageSurface GRC.FormatARGB32 w h
  dCairo        ← cairoCreate  dSurface
  dGIC          ← cairoToGICairo dCairo

  let (dx, dy) = (fromIntegral w, fromIntegral $ -h)
      -- position = V.fromList [ LCLin.V3  0 dy 0, LCLin.V3  0  0 0, LCLin.V3 dx  0 0, LCLin.V3  0 dy 0, LCLin.V3 dx  0 0, LCLin.V3 dx dy 0 ]
      position = V.fromList [ LCLin.V2  0 dy,   LCLin.V2  0  0,   LCLin.V2 dx  0,   LCLin.V2  0 dy,   LCLin.V2 dx  0,   LCLin.V2 dx dy ]
      texcoord = V.fromList [ LCLin.V2  0  1,   LCLin.V2  0  0,   LCLin.V2  1  0,   LCLin.V2  0  1,   LCLin.V2  1  0,   LCLin.V2  1  1 ]
      dMesh    = LC.Mesh { mPrimitive  = P_Triangles
                         , mAttributes = Map.fromList [ ("position",  A_V2F position)
                                                      , ("uv",        A_V2F texcoord) ] }
  dGPUMesh      ← GL.uploadMeshToGPU dMesh
  SMem.addFinalizer dGPUMesh $
    GL.disposeMesh dGPUMesh
  dGLObject     ← GL.addMeshToObjectArray osStorage (fromOANS osObjArray) [unameStr osUniform, "viewProj"] dGPUMesh

  dSurfaceData  ← imageSurfaceGetPixels' dSurface
  dTexId        ← F.alloca $! \pto → glGenTextures 1 pto >> F.peek pto

  -- dTexture      ← uploadTexture2DToGPU'''' False False False False $ (fromWi dStridePixels, h, GL_BGRA, pixels)
  pure Drawable{..}

disposeDrawable ∷ (MonadIO m) ⇒ ObjectStream → Drawable → m ()
disposeDrawable ObjectStream{..} Drawable{..} = liftIO $ do
  -- see experiment in LCstress
  F.withArray [dTexId] $ glDeleteTextures 1 -- release tex id
  GL.removeObject osStorage dGLObject
  -- GL.disposeMesh  dGPUMesh
  -- cairoCreate is auto-managed
  GRCI.surfaceFinish dSurface -- undo createImageSurface
{'fraction_non_alphanumeric': 0.09061621368322399, 'fraction_numerical': 0.008083411433926898, 'mean_word_length': 2.440056417489422, 'pattern_counts': {'":': 0, '<': 11, '<?xml version=': 0, '>': 15, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 6, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '4284744', 'n_tokens_mistral': 6060, 'n_tokens_neox': 5833, 'n_words': 1801}