diff --git a/.envrc b/.envrc new file mode 100644 index 0000000..1d953f4 --- /dev/null +++ b/.envrc @@ -0,0 +1 @@ +use nix diff --git a/.stylish-haskell.yaml b/.stylish-haskell.yaml new file mode 100644 index 0000000..05dbef7 --- /dev/null +++ b/.stylish-haskell.yaml @@ -0,0 +1,357 @@ +# stylish-haskell configuration file +# ================================== + +# The stylish-haskell tool is mainly configured by specifying steps. These steps +# are a list, so they have an order, and one specific step may appear more than +# once (if needed). Each file is processed by these steps in the given order. +steps: + # Convert some ASCII sequences to their Unicode equivalents. This is disabled + # by default. + # - unicode_syntax: + # # In order to make this work, we also need to insert the UnicodeSyntax + # # language pragma. If this flag is set to true, we insert it when it's + # # not already present. You may want to disable it if you configure + # # language extensions using some other method than pragmas. Default: + # # true. + # add_language_pragma: true + + # Format module header + # + # Currently, this option is not configurable and will format all exports and + # module declarations to minimize diffs + # + # - module_header: + # # How many spaces use for indentation in the module header. + # indent: 4 + # + # # Should export lists be sorted? Sorting is only performed within the + # # export section, as delineated by Haddock comments. + # sort: true + # + # # See `separate_lists` for the `imports` step. + # separate_lists: true + + # Format record definitions. This is disabled by default. + # + # You can control the layout of record fields. The only rules that can't be configured + # are these: + # + # - "|" is always aligned with "=" + # - "," in fields is always aligned with "{" + # - "}" is likewise always aligned with "{" + # + # - records: + # # How to format equals sign between type constructor and data constructor. + # # Possible values: + # # - "same_line" -- leave "=" AND data constructor on the same line as the type constructor. + # # - "indent N" -- insert a new line and N spaces from the beginning of the next line. + # equals: "indent 2" + # + # # How to format first field of each record constructor. + # # Possible values: + # # - "same_line" -- "{" and first field goes on the same line as the data constructor. + # # - "indent N" -- insert a new line and N spaces from the beginning of the data constructor + # first_field: "indent 2" + # + # # How many spaces to insert between the column with "," and the beginning of the comment in the next line. + # field_comment: 2 + # + # # How many spaces to insert before "deriving" clause. Deriving clauses are always on separate lines. + # deriving: 2 + # + # # How many spaces to insert before "via" clause counted from indentation of deriving clause + # # Possible values: + # # - "same_line" -- "via" part goes on the same line as "deriving" keyword. + # # - "indent N" -- insert a new line and N spaces from the beginning of "deriving" keyword. + # via: "indent 2" + # + # # Sort typeclass names in the "deriving" list alphabetically. + # sort_deriving: true + # + # # Wheter or not to break enums onto several lines + # # + # # Default: false + # break_enums: false + # + # # Whether or not to break single constructor data types before `=` sign + # # + # # Default: true + # break_single_constructors: true + # + # # Whether or not to curry constraints on function. + # # + # # E.g: @allValues :: Enum a => Bounded a => Proxy a -> [a]@ + # # + # # Instead of @allValues :: (Enum a, Bounded a) => Proxy a -> [a]@ + # # + # # Default: false + # curried_context: false + + # Align the right hand side of some elements. This is quite conservative + # and only applies to statements where each element occupies a single + # line. + # Possible values: + # - always - Always align statements. + # - adjacent - Align statements that are on adjacent lines in groups. + # - never - Never align statements. + # All default to always. + - simple_align: + cases: always + top_level_patterns: always + records: always + multi_way_if: always + + # Import cleanup + - imports: + # There are different ways we can align names and lists. + # + # - global: Align the import names and import list throughout the entire + # file. + # + # - file: Like global, but don't add padding when there are no qualified + # imports in the file. + # + # - group: Only align the imports per group (a group is formed by adjacent + # import lines). + # + # - none: Do not perform any alignment. + # + # Default: global. + align: none + + # The following options affect only import list alignment. + # + # List align has following options: + # + # - after_alias: Import list is aligned with end of import including + # 'as' and 'hiding' keywords. + # + # > import qualified Data.List as List (concat, foldl, foldr, head, + # > init, last, length) + # + # - with_alias: Import list is aligned with start of alias or hiding. + # + # > import qualified Data.List as List (concat, foldl, foldr, head, + # > init, last, length) + # + # - with_module_name: Import list is aligned `list_padding` spaces after + # the module name. + # + # > import qualified Data.List as List (concat, foldl, foldr, head, + # init, last, length) + # + # This is mainly intended for use with `pad_module_names: false`. + # + # > import qualified Data.List as List (concat, foldl, foldr, head, + # init, last, length, scanl, scanr, take, drop, + # sort, nub) + # + # - new_line: Import list starts always on new line. + # + # > import qualified Data.List as List + # > (concat, foldl, foldr, head, init, last, length) + # + # - repeat: Repeat the module name to align the import list. + # + # > import qualified Data.List as List (concat, foldl, foldr, head) + # > import qualified Data.List as List (init, last, length) + # + # Default: after_alias + list_align: after_alias + + # Right-pad the module names to align imports in a group: + # + # - true: a little more readable + # + # > import qualified Data.List as List (concat, foldl, foldr, + # > init, last, length) + # > import qualified Data.List.Extra as List (concat, foldl, foldr, + # > init, last, length) + # + # - false: diff-safe + # + # > import qualified Data.List as List (concat, foldl, foldr, init, + # > last, length) + # > import qualified Data.List.Extra as List (concat, foldl, foldr, + # > init, last, length) + # + # Default: true + pad_module_names: true + + # Long list align style takes effect when import is too long. This is + # determined by 'columns' setting. + # + # - inline: This option will put as much specs on same line as possible. + # + # - new_line: Import list will start on new line. + # + # - new_line_multiline: Import list will start on new line when it's + # short enough to fit to single line. Otherwise it'll be multiline. + # + # - multiline: One line per import list entry. + # Type with constructor list acts like single import. + # + # > import qualified Data.Map as M + # > ( empty + # > , singleton + # > , ... + # > , delete + # > ) + # + # Default: inline + long_list_align: inline + + # Align empty list (importing instances) + # + # Empty list align has following options + # + # - inherit: inherit list_align setting + # + # - right_after: () is right after the module name: + # + # > import Vector.Instances () + # + # Default: inherit + empty_list_align: inherit + + # List padding determines indentation of import list on lines after import. + # This option affects 'long_list_align'. + # + # - : constant value + # + # - module_name: align under start of module name. + # Useful for 'file' and 'group' align settings. + # + # Default: 4 + list_padding: 4 + + # Separate lists option affects formatting of import list for type + # or class. The only difference is single space between type and list + # of constructors, selectors and class functions. + # + # - true: There is single space between Foldable type and list of it's + # functions. + # + # > import Data.Foldable (Foldable (fold, foldl, foldMap)) + # + # - false: There is no space between Foldable type and list of it's + # functions. + # + # > import Data.Foldable (Foldable(fold, foldl, foldMap)) + # + # Default: true + separate_lists: true + + # Space surround option affects formatting of import lists on a single + # line. The only difference is single space after the initial + # parenthesis and a single space before the terminal parenthesis. + # + # - true: There is single space associated with the enclosing + # parenthesis. + # + # > import Data.Foo ( foo ) + # + # - false: There is no space associated with the enclosing parenthesis + # + # > import Data.Foo (foo) + # + # Default: false + space_surround: false + + # Enabling this argument will use the new GHC lib parse to format imports. + # + # This currently assumes a few things, it will assume that you want post + # qualified imports. It is also not as feature complete as the old + # imports formatting. + # + # It does not remove redundant lines or merge lines. As such, the full + # feature scope is still pending. + # + # It _is_ however, a fine alternative if you are using features that are + # not parseable by haskell src extensions and you're comfortable with the + # presets. + # + # Default: false + ghc_lib_parser: false + + # Language pragmas + - language_pragmas: + # We can generate different styles of language pragma lists. + # + # - vertical: Vertical-spaced language pragmas, one per line. + # + # - compact: A more compact style. + # + # - compact_line: Similar to compact, but wrap each line with + # `{-#LANGUAGE #-}'. + # + # Default: vertical. + style: vertical + + # Align affects alignment of closing pragma brackets. + # + # - true: Brackets are aligned in same column. + # + # - false: Brackets are not aligned together. There is only one space + # between actual import and closing bracket. + # + # Default: true + align: false + + # stylish-haskell can detect redundancy of some language pragmas. If this + # is set to true, it will remove those redundant pragmas. Default: true. + remove_redundant: true + + # Language prefix to be used for pragma declaration, this allows you to + # use other options non case-sensitive like "language" or "Language". + # If a non correct String is provided, it will default to: LANGUAGE. + language_prefix: LANGUAGE + + # Replace tabs by spaces. This is disabled by default. + # - tabs: + # # Number of spaces to use for each tab. Default: 8, as specified by the + # # Haskell report. + # spaces: 8 + + # Remove trailing whitespace + - trailing_whitespace: {} + + # Squash multiple spaces between the left and right hand sides of some + # elements into single spaces. Basically, this undoes the effect of + # simple_align but is a bit less conservative. + # - squash: {} + +# A common setting is the number of columns (parts of) code will be wrapped +# to. Different steps take this into account. +# +# Set this to null to disable all line wrapping. +# +# Default: 80. +columns: 80 + +# By default, line endings are converted according to the OS. You can override +# preferred format here. +# +# - native: Native newline format. CRLF on Windows, LF on other OSes. +# +# - lf: Convert to LF ("\n"). +# +# - crlf: Convert to CRLF ("\r\n"). +# +# Default: native. +newline: native + +# Sometimes, language extensions are specified in a cabal file or from the +# command line instead of using language pragmas in the file. stylish-haskell +# needs to be aware of these, so it can parse the file correctly. +# +# No language extensions are enabled by default. +# language_extensions: + # - TemplateHaskell + # - QuasiQuotes + +# Attempt to find the cabal file in ancestors of the current directory, and +# parse options (currently only language extensions) from that. +# +# Default: true +cabal: true diff --git a/implicitpipe.cabal b/implicitpipe.cabal index 74396af..682f7d1 100644 --- a/implicitpipe.cabal +++ b/implicitpipe.cabal @@ -20,8 +20,8 @@ library , directory , filepath , fsnotify - , GPipe >=2.2 - , GPipe-GLFW >=1.4 + , GPipe-Core >= 0.2.3 + , GPipe-GLFW4 >= 2.0.0 , GLFW-b , hint , implicit diff --git a/overlay.nix b/overlay.nix index d195c5d..1da83ab 100644 --- a/overlay.nix +++ b/overlay.nix @@ -1,20 +1,17 @@ (self: super: let gpipeSrc = super.fetchFromGitHub { - # fork due to resizeBuffer PR https://github.com/tobbebex/GPipe-Core/pull/76 - # owner = "tobbebex"; - owner = "sorki"; + owner = "homectl"; repo = "GPipe-Core"; - rev = "86a7b29014e7ebfb24ac17d5afcd877a38a1fbd5"; - sha256 = "08mvgygiq6i6vfjak4pq3cz1w3scvwv10igxn4vz6mna5fq6mnxz"; + rev = "273f58fc53e8560ed72f0e62867b96e4afec92c3"; + sha256 = "06lm8mj7d5lpi5f8cgas4rx1xq5wagb9n3j7cfip2zckwrq7rl5j"; }; - # until 2.0 gpipeGlfwSrc = super.fetchFromGitHub { - owner = "plredmond"; - repo = "GPipe-GLFW"; - rev = "83d26eb7b41d67f5ac6fbd1bd8758d72c660e039"; - sha256 = "0fg60amvp2v37cwmvfa0n7if1ppisjjh3bknmrr17m7fbfbbxlhq"; + owner = "homectl"; + repo = "GPipe-GLFW4"; + rev = "999b55e2cf78c052884f5ec9ab154e3cc399ba7a"; + sha256 = "09182qs5cf5glhxavcp24f74f1kkk5pfdwmah2rg31ggz1wa5m81"; }; in ({ @@ -25,12 +22,12 @@ in GPipe = hsuper.callCabal2nix "GPipe" "${gpipeSrc}/GPipe-Core" {}; GPipe-GLFW = hsuper.callCabal2nix "GPipe-GLFW" ("${gpipeGlfwSrc}/GPipe-GLFW") {}; - # until > 3.0.2 is out + # until > 3.0 is out implicit = hsuper.callCabal2nix "implicit" (super.fetchFromGitHub { owner = "colah"; repo = "ImplicitCAD"; - rev = "8dff5531cdc4d9ed32bf958e3945b4a3a0ef3774"; - sha256 = "0bp797a9wlpyw2d6b4csz5ikqq3wy1qry0iabl7r7axjrhvnfp56"; + rev = "67ab4ccc046e255e36c49e40ae2ceedda6a49400"; + sha256 = "1w4xjdxgc9mfjm681pdnhzcxvppvmn9p381gpfl30b8rvbgzjj4d"; }) {}; }); }); diff --git a/src/Graphics/Implicit/Viewer.hs b/src/Graphics/Implicit/Viewer.hs index 7bdd3ba..b1213b7 100644 --- a/src/Graphics/Implicit/Viewer.hs +++ b/src/Graphics/Implicit/Viewer.hs @@ -1,9 +1,8 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE PackageImports #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} module Graphics.Implicit.Viewer ( animate @@ -24,16 +23,17 @@ import Control.Monad.IO.Class import Data.Default import qualified Data.Map -import Graphics.GPipe hiding ((^-^), rotate, mod') -import Graphics.UI.GLFW (WindowHint(..)) -import qualified "GPipe-GLFW" Graphics.GPipe.Context.GLFW as GLFW +import Graphics.GPipe hiding (mod', rotate, (^-^)) +import Graphics.GPipe.Buffer (resizeBuffer) +import qualified Graphics.GPipe.Context.GLFW as GLFW +import Graphics.UI.GLFW (WindowHint (..)) import Graphics.Implicit +import Graphics.Implicit.Viewer.Demos import Graphics.Implicit.Viewer.Loaders import Graphics.Implicit.Viewer.Shaders import Graphics.Implicit.Viewer.Types import Graphics.Implicit.Viewer.Util -import Graphics.Implicit.Viewer.Demos -- | View `SymbolicObj3` object using OpenGL viewer view :: SymbolicObj3 -> IO () @@ -117,7 +117,7 @@ viewer config@ViewerConf{..} = do fragmentStream <- do - guard' (shaderEnvFlatNormals) + guard' shaderEnvFlatNormals rasterize shaderEnvRasterOptions (proj Flat <$> primitiveStream) @@ -197,8 +197,8 @@ loop win shader triangles unionBuffers@Uniforms{..} aTime eventChan renderChan v projMat = perspective (pi/2) (fromIntegral windowWidth / fromIntegral windowHeight) 0.1 100 - eye = (V3 0 (-1) 1) - lookAtPoint = (V3 0 0 0) + eye = V3 0 (-1) 1 + lookAtPoint = V3 0 0 0 cameraMatrix :: M44 Float cameraMatrix = @@ -238,6 +238,7 @@ loop win shader triangles unionBuffers@Uniforms{..} aTime eventChan renderChan v $ ShaderEnvironment primitiveArray ( FrontAndBack + , PolygonFill , ViewPort 0 windowSize , DepthRange 0 1 ) @@ -276,8 +277,8 @@ updateViewerState win chan oldState = do V2 cursorX cursorY = lastCursorPos in s { lastCursorPos = x - , camPitch = ((realToFrac $ cursorY - oldCursorY) / 100 + camPitch) `mod''` (2*pi) - , camYaw = ((realToFrac $ cursorX - oldCursorX) / 100 + camYaw) `mod''` (2*pi) + , camPitch = (realToFrac (cursorY - oldCursorY) / 100 + camPitch) `mod''` (2*pi) + , camYaw = (realToFrac (cursorX - oldCursorX) / 100 + camYaw) `mod''` (2*pi) } LeftMouse x -> s { camRotating = x } @@ -303,13 +304,13 @@ updateViewerState win chan oldState = do spaceKey <- GLFW.getKey win GLFW.Key'Space let faster = case spaceKey of Just GLFW.KeyState'Pressed -> (*10) - _ -> id + _ -> id animDirection = if animationForward then 1 else -1 animTime = if animationRunning - then animationTime + (faster $ animDirection * animationStep) + then animationTime + faster (animDirection * animationStep) else animationTime nextOutOfBounds = @@ -376,4 +377,4 @@ setupCallbacks win chan = do when (keyState == GLFW.KeyState'Pressed) $ do case Data.Map.lookup key keyMap of Just message -> atomically $ writeTChan chan message - _ -> return () + _ -> return () diff --git a/src/Graphics/Implicit/Viewer/Config.hs b/src/Graphics/Implicit/Viewer/Config.hs index 9884f0c..dd19f59 100644 --- a/src/Graphics/Implicit/Viewer/Config.hs +++ b/src/Graphics/Implicit/Viewer/Config.hs @@ -20,7 +20,7 @@ data Resolution = -- | Scale resolution by function apResolution :: (Double -> Double) -> Resolution -> Resolution -apResolution f (Fixed n) = Fixed (f n) +apResolution f (Fixed n) = Fixed (f n) apResolution f (Varied f') = Varied $ f' . f meshFunFromResolution @@ -28,7 +28,7 @@ meshFunFromResolution -> Double -> SymbolicObj3 -> NormedTriangleMesh -meshFunFromResolution (Fixed n) = const $ discreteAprox n +meshFunFromResolution (Fixed n) = const $ discreteAprox n meshFunFromResolution (Varied f) = f data ViewerConf = ViewerConf diff --git a/src/Graphics/Implicit/Viewer/Demos.hs b/src/Graphics/Implicit/Viewer/Demos.hs index 12f4304..27bd0fa 100644 --- a/src/Graphics/Implicit/Viewer/Demos.hs +++ b/src/Graphics/Implicit/Viewer/Demos.hs @@ -1,7 +1,6 @@ {-# OPTIONS_GHC -fno-warn-type-defaults #-} module Graphics.Implicit.Viewer.Demos where -import Linear import Graphics.Implicit import Graphics.Implicit.Primitives @@ -22,8 +21,8 @@ demoRotatingAnim t = ontop :: SymbolicObj3 -> SymbolicObj3 -> SymbolicObj3 ontop a b = union [ translate (V3 0 0 z) a, b ] where z = let - ((V3 _ _ aBottom), _) = getBox a - (_, (V3 _ _ bTop)) = getBox b + (V3 _ _ aBottom, _) = getBox a + (_, V3 _ _ bTop) = getBox b in bTop - aBottom demoTranslatedSymbolic :: SymbolicObj3 diff --git a/src/Graphics/Implicit/Viewer/Loaders.hs b/src/Graphics/Implicit/Viewer/Loaders.hs index efe2eb7..9e81ec5 100644 --- a/src/Graphics/Implicit/Viewer/Loaders.hs +++ b/src/Graphics/Implicit/Viewer/Loaders.hs @@ -1,8 +1,8 @@ {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} module Graphics.Implicit.Viewer.Loaders where @@ -10,23 +10,22 @@ import Control.Concurrent import Control.Concurrent.Async import Control.Concurrent.STM import Control.Monad -import Control.Monad.Trans.Maybe (runMaybeT, MaybeT(..)) +import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT) import Data.Foldable (asum) import Data.List (isSuffixOf) -import Data.Time (getCurrentTime, diffUTCTime) +import Data.Time (diffUTCTime, getCurrentTime) import Data.Typeable (Typeable) -import Linear (V3(V3)) import Graphics.Implicit -import Graphics.Implicit.Primitives (getBox) +import Graphics.Implicit.Export.GL import Graphics.Implicit.ExtOpenScad.Definitions +import Graphics.Implicit.Primitives (getBox) import Graphics.Implicit.Viewer.Types -import Graphics.Implicit.Export.GL import qualified Language.Haskell.Interpreter as Hint +import qualified System.Directory import qualified System.FSNotify as FSNotify import qualified System.FilePath -import qualified System.Directory -- | Run fsnotify based directory watcher for .hs and .escad files -- and run appropriate loader based on the file extension. @@ -102,7 +101,7 @@ loadViaHint modFile initialResolution renderChan = do mo <- eval @SymbolicObj3 modFile "obj" case mo of - Right o -> renderObjToChan o resolution renderChan + Right o -> renderObjToChan o resolution renderChan Left (Hint.WontCompile ghcErrs) -> forM_ ghcErrs $ putStrLn . Hint.errMsg Left (Hint.UnknownError str) -> putStrLn $ "Unknown error: " ++ str Left (Hint.NotAllowed str) -> putStrLn $ "Not allowed: " ++ str @@ -127,7 +126,7 @@ evalMay :: forall t. Typeable t evalMay modFile s = toMaybe $ eval modFile s where toMaybe a = a >>= return . \case Right x -> Just x - _ -> Nothing + _ -> Nothing loadViaEscad :: FilePath @@ -154,7 +153,7 @@ loadViaEscad modFile initialResolution renderChan = do let res = case lookupVarIn "$res" varLookup of Just (ONum n) -> Fixed n - _ -> initialResolution + _ -> initialResolution renderObjToChan (unionR 0 ((extrude (unionR 0 objs2) 1):objs3)) @@ -185,7 +184,7 @@ renderObjToChan o resolution renderChan = do unless (l == 0) $ do atomically $ writeTChan renderChan (l, objScale, mesh) after <- getCurrentTime - putStrLn $ "Done in " ++ (show $ diffUTCTime after now) + putStrLn $ "Done in " ++ show (diffUTCTime after now) when (l == 0) $ putStrLn "Mesh empty" @@ -200,6 +199,6 @@ runAnimation f initialResolution renderChan aTime = void $ async $ forever $ do isE <- atomically $ isEmptyTChan renderChan case isE of True -> do - t <- atomically $ readTVar aTime + t <- readTVarIO aTime renderObjToChan (f t) initialResolution renderChan False -> threadDelay 100000 diff --git a/src/Graphics/Implicit/Viewer/Shaders.hs b/src/Graphics/Implicit/Viewer/Shaders.hs index 9e183af..e3fb394 100644 --- a/src/Graphics/Implicit/Viewer/Shaders.hs +++ b/src/Graphics/Implicit/Viewer/Shaders.hs @@ -1,15 +1,15 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Graphics.Implicit.Viewer.Shaders where -import Data.Map (Map) -import qualified Data.Map import Data.Default import Data.Foldable +import Data.Map (Map) +import qualified Data.Map import Graphics.GPipe import Graphics.Implicit.Viewer.Types @@ -32,7 +32,7 @@ allShaders = Data.Map.fromList $ zip [0..] asumShaderByID :: forall os - . ((ShaderEnvironment os) -> Int) + . (ShaderEnvironment os -> Int) -> Window os RGBAFloat Depth -> FragStream -> Shader os (ShaderEnvironment os) () @@ -62,16 +62,16 @@ computeLight specularIntensity eye VertexInfo{..} = halfVector = signorm viewDir specular = maxB (viNormal `dot` halfVector) 0 in - specularIntensity *^ (V4 1 1 1 1) ^* (specular ** 32) + specularIntensity *^ V4 1 1 1 1 ^* (specular ** 32) + (1 *^ opaque $ 0.1 -- global illumination + ( -- red light from front right - (V3 0.8 0 0 ^* (maxB (normal `dot` dirR) 0)) + (V3 0.8 0 0 ^* maxB (normal `dot` dirR) 0) -- green from front left - + (V3 0 0.8 0 ^* (maxB (normal `dot` dirG) 0)) + + (V3 0 0.8 0 ^* maxB (normal `dot` dirG) 0) -- blue from bottom - + (V3 0 0 0.8 ^* (maxB (normal `dot` dirB) 0)) + + (V3 0 0 0.8 ^* maxB (normal `dot` dirB) 0) )) lightShaded @@ -82,7 +82,7 @@ lightShaded lightShaded i win fragStream = do eye <- getUni bEye let - litFrags = (computeLight i eye) <$> fragStream + litFrags = computeLight i eye <$> fragStream drawWindowColorDepth (const (win, def, def)) @@ -100,7 +100,7 @@ alphaWireframe win fragStream = do (V3 i j k) = w edgeFactor = minB (minB i j) k in - (V4 1 0 0 ((1.0 - edgeFactor) * 0.95)) + V4 1 0 0 ((1.0 - edgeFactor) * 0.95) drawWindowColor (const (win, blendAlpha)) @@ -125,7 +125,7 @@ edgy win fragStream = do drawWindowColor (const (win, blendAlpha)) - (wireFrags) + wireFrags edges :: forall os . Window os RGBAFloat Depth diff --git a/src/Graphics/Implicit/Viewer/Types.hs b/src/Graphics/Implicit/Viewer/Types.hs index 543b352..cb936f5 100644 --- a/src/Graphics/Implicit/Viewer/Types.hs +++ b/src/Graphics/Implicit/Viewer/Types.hs @@ -1,7 +1,7 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE Arrows #-} -{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TypeFamilies #-} -- due to getUni which explodes when given signature {-# OPTIONS_GHC -fno-warn-missing-signatures #-} @@ -56,7 +56,7 @@ getUni which = getUniform (\state -> (which $ shaderEnvUniforms state, 0)) data ShaderEnvironment os = ShaderEnvironment { shaderEnvTriangles :: PrimitiveArray Triangles PrimitiveBuffer - , shaderEnvRasterOptions :: (Side, ViewPort, DepthRange) + , shaderEnvRasterOptions :: (Side, PolygonMode, ViewPort, DepthRange) , shaderEnvFragID :: Int -- fragment shader ID , shaderEnvUniforms :: Uniforms os , shaderEnvFlatNormals :: Bool diff --git a/src/Graphics/Implicit/Viewer/Util.hs b/src/Graphics/Implicit/Viewer/Util.hs index fa02539..cb5532c 100644 --- a/src/Graphics/Implicit/Viewer/Util.hs +++ b/src/Graphics/Implicit/Viewer/Util.hs @@ -1,9 +1,9 @@ module Graphics.Implicit.Viewer.Util where -import Linear import Data.Map (Map) import qualified Data.Map +import Linear mkScaleTransform :: Float -> M44 Float mkScaleTransform s =