keid-geometry (empty) → 0.1.0.0

raw patch · 10 files changed

+592/−0 lines, 10 filesdep +basedep +geomancydep +keid-coresetup-changed

Dependencies added: base, geomancy, keid-core, rio, rio-app, vulkan

Files

• ChangeLog.md +3/−0
• LICENSE +30/−0
• README.md +1/−0
• Setup.hs +2/−0
• keid-geometry.cabal +101/−0
• src/Geometry/Cube.hs +145/−0
• src/Geometry/Edge.hs +24/−0
• src/Geometry/Face.hs +27/−0
• src/Geometry/Icosphere.hs +179/−0
• src/Geometry/Quad.hs +80/−0

@@ -0,0 +1,3 @@+# Changelog for keid-geometry++## Unreleased changes

@@ -0,0 +1,30 @@+Copyright IC Rainbow (c) 2021++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Author name here nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,1 @@+# Keid Engine - Geometry utils

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,101 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.34.4.+--+-- see: https://github.com/sol/hpack++name:           keid-geometry+version:        0.1.0.0+synopsis:       Geometry primitives for Keid engine.+category:       Game Engine+author:         IC Rainbow+maintainer:     keid@aenor.ru+copyright:      2021 IC Rainbow+license:        BSD3+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    ChangeLog.md++source-repository head+  type: git+  location: https://gitlab.com/keid/engine++library+  exposed-modules:+      Geometry.Cube+      Geometry.Edge+      Geometry.Face+      Geometry.Icosphere+      Geometry.Quad+  other-modules:+      Paths_keid_geometry+  hs-source-dirs:+      src+  default-extensions:+      NoImplicitPrelude+      ApplicativeDo+      BangPatterns+      BinaryLiterals+      BlockArguments+      ConstrainedClassMethods+      ConstraintKinds+      DataKinds+      DefaultSignatures+      DeriveDataTypeable+      DeriveFunctor+      DeriveGeneric+      DeriveLift+      DeriveTraversable+      DerivingStrategies+      DerivingVia+      DuplicateRecordFields+      EmptyCase+      EmptyDataDeriving+      ExistentialQuantification+      ExplicitForAll+      FlexibleContexts+      FlexibleInstances+      FunctionalDependencies+      GADTs+      GeneralizedNewtypeDeriving+      HexFloatLiterals+      ImportQualifiedPost+      InstanceSigs+      KindSignatures+      LambdaCase+      LiberalTypeSynonyms+      MultiParamTypeClasses+      NamedFieldPuns+      NamedWildCards+      NumDecimals+      NumericUnderscores+      OverloadedStrings+      PatternSynonyms+      PostfixOperators+      QuantifiedConstraints+      QuasiQuotes+      RankNTypes+      RecordWildCards+      ScopedTypeVariables+      StandaloneDeriving+      StandaloneKindSignatures+      StrictData+      TemplateHaskell+      TupleSections+      TypeApplications+      TypeFamilies+      TypeOperators+      TypeSynonymInstances+      UnicodeSyntax+      ViewPatterns+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints+  build-depends:+      base >=4.7 && <5+    , geomancy+    , keid-core+    , rio >=0.1.12.0+    , rio-app+    , vulkan+  default-language: Haskell2010

@@ -0,0 +1,145 @@+module Geometry.Cube where++import RIO++import Geomancy (Vec3, Vec4, vec3, vec4)+import Geomancy.Vec3 qualified as Vec3++import Resource.Model qualified as Model++data Vertices a = Vertices+  { vLTN :: a+  , vLTF :: a+  , vLBN :: a+  , vLBF :: a+  , vRTN :: a+  , vRTF :: a+  , vRBN :: a+  , vRBF :: a+  }+  deriving (Eq, Ord, Show, Functor, Foldable, Traversable)++-- | Unit cube vertices centered at (0,0,0).+positions :: Vertices Vec3+positions = Vertices+  { vLTN = vec3 (-0.5) (-0.5) (-0.5)+  , vLTF = vec3 (-0.5) (-0.5)   0.5+  , vLBN = vec3 (-0.5)   0.5  (-0.5)+  , vLBF = vec3 (-0.5)   0.5    0.5+  , vRTN = vec3   0.5  (-0.5) (-0.5)+  , vRTF = vec3   0.5  (-0.5)   0.5+  , vRBN = vec3   0.5    0.5  (-0.5)+  , vRBF = vec3   0.5    0.5    0.5+  }++instance Applicative Vertices where+  {-# INLINE pure #-}+  pure x = Vertices+    { vLTN = x+    , vLTF = x+    , vLBN = x+    , vLBF = x+    , vRTN = x+    , vRTF = x+    , vRBN = x+    , vRBF = x+    }++  funcs <*> args = Vertices+    { vLTN = vLTN funcs $ vLTN args+    , vLTF = vLTF funcs $ vLTF args+    , vLBN = vLBN funcs $ vLBN args+    , vLBF = vLBF funcs $ vLBF args+    , vRTN = vRTN funcs $ vRTN args+    , vRTF = vRTF funcs $ vRTF args+    , vRBN = vRBN funcs $ vRBN args+    , vRBF = vRBF funcs $ vRBF args+    }++edges :: [Vec3]+edges =+  [ -- XXX: top plane+    vLTF+  , vLTN++  , vRTF+  , vRTN++  , vLTF+  , vRTF++  , vLTN+  , vRTN++    -- XXX: bottom plane+  , vLBF+  , vLBN++  , vRBF+  , vRBN++  , vLBF+  , vRBF++  , vLBN+  , vRBN++    -- XXX: vertical bars+  , vLTN+  , vLBN++  , vRTN+  , vRBN++  , vLTF+  , vLBF++  , vRTF+  , vRBF+  ]+  where+    Vertices{..} = positions++bbWireColored :: [Model.Vertex Vec3.Packed Vec4]+bbWireColored = zipWith Model.Vertex (map Vec3.Packed edges) colors+  where+    colors =+      [ -- XXX: top plane - red+        vec4 1 0 0 1+      , vec4 1 0 0 1++      , vec4 1 0 0 1+      , vec4 1 0 0 1++      , vec4 1 0 0 1+      , vec4 1 0 0 1++      , vec4 1 0 0 1+      , vec4 1 0 0 1++        -- XXX: bottom plane - green+      , vec4 0 1 0 1+      , vec4 0 1 0 1++      , vec4 0 1 0 1+      , vec4 0 1 0 1++      , vec4 0 1 0 1+      , vec4 0 1 0 1++      , vec4 0 1 0 1+      , vec4 0 1 0 1++        -- XXX: vertical bars - blue+      , vec4 0 0 1 1+      , vec4 0 0 1 1++      , vec4 0 0 1 1+      , vec4 0 0 1 1++      , vec4 0 0 1 1+      , vec4 0 0 1 1++      , vec4 0 0 1 1+      , vec4 0 0 1 1+      ]

@@ -0,0 +1,24 @@+module Geometry.Edge where++import RIO++data Edge a = Edge+  { edgeFrom :: a+  , edgeTo   :: a+  } deriving (Eq, Ord, Show, Functor, Foldable, Traversable)++{-# INLINEABLE edgesR #-}+edgesR :: [a] -> Maybe [Edge a]+edgesR xs = go (Just []) xs+  where+    go acc = \case+      [] ->+        acc+      [_one] ->+        Nothing+      edgeFrom : edgeTo : next ->+        case acc of+          Nothing ->+            go (Just [Edge{..}]) next+          Just old ->+            go (Just (Edge{..} : old)) next

@@ -0,0 +1,27 @@+module Geometry.Face where++import RIO++data Face a = Face+  { faceA :: a+  , faceB :: a+  , faceC :: a+  } deriving (Eq, Ord, Show, Functor, Foldable, Traversable)++{-# INLINEABLE facesR #-}+facesR :: [a] -> Maybe [Face a]+facesR xs = go (Just []) xs+  where+    go acc = \case+      [] ->+        acc+      [_one] ->+        Nothing+      [_one, _two] ->+        Nothing+      faceA : faceB : faceC : next ->+        case acc of+          Nothing ->+            go (Just [Face{..}]) next+          Just old ->+            go (Just (Face{..} : old)) next

@@ -0,0 +1,179 @@+module Geometry.Icosphere where++import RIO++import Data.List (iterate, (!!))+import RIO.Vector.Partial ((!))++import RIO.Vector qualified as Vector+import Geomancy.Vec3 (Vec3, vec3)+import Geomancy.Vec3 qualified as Vec3++import Resource.Model qualified as Model++icosphere :: (Vec3 -> attrs) -> Int -> [Model.Vertex Vec3.Packed attrs]+icosphere mkAttrs n = do+  v <- reverse . concat $ subNormal n icotris_v1+  pure Model.Vertex+    { vPosition = Vec3.Packed v+    , vAttrs    = mkAttrs v+    }++subNormal :: Int -> [[Vec3]] -> [[Vec3]]+subNormal nu tris = map (map Vec3.normalize) $ subdivide nu tris++subdivide :: Int -> [[Vec3]] -> [[Vec3]]+subdivide frequency tris =+  iterate (concatMap subdivideTri) tris !! (frequency - 1)+  where+    subdivideTri = \case+      [v1, v2, v3] ->+        let+          a = midpoint v1 v2+          b = midpoint v2 v3+          c = midpoint v3 v1+        in+          [ [ v1, a, c ]+          , [ v2, b, a ]+          , [ v3, c, b ]+          , [  a, b, c ]+          ]+      _ ->+        error "subdivideTri: not a triangle somehow"++    midpoint a b = (a + b) / 2++icopoints :: Vector Vec3+icopoints = Vector.fromList+  [ vec3 (-1) 0   t+  , vec3   1  0   t+  , vec3 (-1) 0 (-t)+  , vec3   1  0 (-t)++  , vec3   0 (-t) (-1)+  , vec3   0 (-t)   1+  , vec3   0   t  (-1)+  , vec3   0   t    1++  , vec3   t     1  0+  , vec3   t   (-1) 0+  , vec3 (-t)    1  0+  , vec3 (-t)  (-1) 0+  ]+  where+    t = (1.0 + sqrt 5.0) / 2.0++icotris_v1 :: [[Vec3]]+icotris_v1 =+  [ -- faces around point 0+    [ icopoints ! 0+    , icopoints ! 11+    , icopoints ! 5+    ]++  , [ icopoints ! 0+    , icopoints ! 5+    , icopoints ! 1+    ]++  , [ icopoints ! 0+    , icopoints ! 1+    , icopoints ! 7+    ]+{-+  , [ icopoints ! 0+    , icopoints ! 1+    , icopoints ! 7+    ]+-}+  , [ icopoints ! 0+    , icopoints ! 7+    , icopoints ! 10+    ]++  , [ icopoints ! 0+    , icopoints ! 10+    , icopoints ! 11+    ]++    -- 5 adjacent faces++  , [ icopoints ! 1+    , icopoints ! 5+    , icopoints ! 9+    ]++  , [ icopoints ! 5+    , icopoints ! 11+    , icopoints ! 4+    ]++  , [ icopoints ! 11+    , icopoints ! 10+    , icopoints ! 2+    ]++  , [ icopoints ! 10+    , icopoints ! 7+    , icopoints ! 6+    ]++  , [ icopoints ! 7+    , icopoints ! 1+    , icopoints ! 8+    ]++    -- 5 adjacent faces around point 3++  , [ icopoints ! 3+    , icopoints ! 9+    , icopoints ! 4+    ]++  , [ icopoints ! 3+    , icopoints ! 4+    , icopoints ! 2+    ]++  , [ icopoints ! 3+    , icopoints ! 2+    , icopoints ! 6+    ]++  , [ icopoints ! 3+    , icopoints ! 6+    , icopoints ! 8+    ]++  , [ icopoints ! 3+    , icopoints ! 8+    , icopoints ! 9+    ]++    -- 5 adjacent faces++  , [ icopoints ! 4+    , icopoints ! 9+    , icopoints ! 5+    ]++  , [ icopoints ! 2+    , icopoints ! 4+    , icopoints ! 11+    ]++  , [ icopoints ! 6+    , icopoints ! 2+    , icopoints ! 10+    ]++  , [ icopoints ! 8+    , icopoints ! 6+    , icopoints ! 7+    ]++  , [ icopoints ! 9+    , icopoints ! 8+    , icopoints ! 1+    ]+  ]

@@ -0,0 +1,80 @@+module Geometry.Quad+  ( coloredQuad+  , texturedQuad++  , Quad(..)+  , toVertices+  , toVertices2++  , quadPositions+  , quadUV+  , quadNormals+  ) where++import RIO++import Geomancy (Vec2, Vec4, vec2, vec3)+import Geomancy.Vec3 qualified as Vec3++import Resource.Model (Vertex(..))++data Quad a = Quad+  { quadLT :: a+  , quadRT :: a+  , quadLB :: a+  , quadRB :: a+  }+  deriving (Eq, Ord, Show, Functor, Foldable, Traversable)++instance Applicative Quad where+  {-# INLINE pure #-}+  pure x = Quad+    { quadLT = x+    , quadRT = x+    , quadLB = x+    , quadRB = x+    }++  funcs <*> args = Quad+    { quadLT = quadLT funcs $ quadLT args+    , quadRT = quadRT funcs $ quadRT args+    , quadLB = quadLB funcs $ quadLB args+    , quadRB = quadRB funcs $ quadRB args+    }++-- | 2 clockwise ordered triangles+toVertices :: Quad (Vertex pos attrs) -> [Vertex pos attrs]+toVertices Quad{..} =+  [ quadLT, quadRT, quadLB+  , quadLB, quadRT, quadRB+  ]++toVertices2 :: Quad (Vertex pos attrs) -> [Vertex pos attrs]+toVertices2 q = vertices <> reverse vertices+  where+    vertices = toVertices q++coloredQuad :: Vec4 -> Quad (Vertex Vec3.Packed Vec4)+coloredQuad color = Vertex <$> quadPositions <*> pure color++texturedQuad :: Quad (Vertex Vec3.Packed Vec2)+texturedQuad = Vertex <$> quadPositions <*> quadUV++quadPositions :: Quad Vec3.Packed+quadPositions = fmap Vec3.Packed Quad+  { quadLT = vec3 (-0.5) (-0.5) 0+  , quadRT = vec3   0.5  (-0.5) 0+  , quadLB = vec3 (-0.5)   0.5  0+  , quadRB = vec3   0.5    0.5  0+  }++quadUV :: Quad Vec2+quadUV = Quad+  { quadLT = vec2 0 0+  , quadRT = vec2 1 0+  , quadLB = vec2 0 1+  , quadRB = vec2 1 1+  }++quadNormals :: Quad Vec3.Packed+quadNormals = pure . Vec3.Packed $ vec3 0 0 (-1)