Southpaw (empty) → 0.1.0.0
raw patch · 19 files changed
+2135/−0 lines, 19 filesdep +ALUTdep +GLFW-bdep +JuicyPixelssetup-changed
Dependencies added: ALUT, GLFW-b, JuicyPixels, OpenAL, OpenGL, Win32, base, bytestring, cairo, containers, filepath, gtk3, vector
Files
- LICENSE.md +21/−0
- README.md +0/−0
- Setup.hs +2/−0
- Southpaw.cabal +90/−0
- lib/Southpaw/AbbeyRoad/Capture.hs +179/−0
- lib/Southpaw/Cartesian/Cartesian.hs +128/−0
- lib/Southpaw/Interactive/Application.hs +87/−0
- lib/Southpaw/Michelangelo/Utils.hs +105/−0
- lib/Southpaw/Picasso/Palette.hs +253/−0
- lib/Southpaw/Picasso/RenderUtils.hs +44/−0
- lib/Southpaw/Unicode/UnicodeTest.hs +27/−0
- lib/Southpaw/Unicode/WinUnicodeConIO.hs +220/−0
- lib/Southpaw/Units/Units.hs +27/−0
- lib/Southpaw/Utilities/Format.hs +72/−0
- lib/Southpaw/Utilities/Utilities.hs +141/−0
- lib/Southpaw/WaveFront/Checks.hs +121/−0
- lib/Southpaw/WaveFront/Foreign.hs +79/−0
- lib/Southpaw/WaveFront/Parsers.hs +438/−0
- lib/Southpaw/WaveFront/Utilities.hs +101/−0
+ LICENSE.md view
@@ -0,0 +1,21 @@+The MIT License (MIT) + +Copyright (c) 2015 Jonatan H Sundqvist + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE.
+ README.md view
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple +main = defaultMain
+ Southpaw.cabal view
@@ -0,0 +1,90 @@+-- Initial Southpaw.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +-- The name of the package. +name: Southpaw + +-- The package version. See the Haskell package versioning policy (PVP) +-- for standards guiding when and how versions should be incremented. +-- http://www.haskell.org/haskellwiki/Package_versioning_policy +-- PVP summary: +-+------- breaking API changes +-- | | +----- non-breaking API additions +-- | | | +--- code changes with no API change +version: 0.1.0.0 + +-- A short (one-line) description of the package. +synopsis: Assorted utility modules + +-- A longer description of the package. +description: Various unrelated utility modules. + +-- The license under which the package is released. +license: MIT + +-- The file containing the license text. +license-file: LICENSE.md + +-- The package author(s). +author: Jonatan H Sundqvist + +-- An email address to which users can send suggestions, bug reports, and +-- patches. +maintainer: jonatanhsundqvist@gmail.com + +-- A copyright notice. +-- copyright: + +category: Utilities + +build-type: Simple + +-- Extra files to be distributed with the package, such as examples or a +-- README. +extra-source-files: README.md + +-- Constraint on the version of Cabal needed to build this package. +cabal-version: >=1.10 + + +source-repository head + type: git + location: https://github.com/SwiftsNamesake/Southpaw.git + + +library + -- Modules exported by the library. + exposed-modules: Southpaw.WaveFront.Parsers, Southpaw.WaveFront.Foreign, Southpaw.WaveFront.Checks, Southpaw.WaveFront.Utilities, + Southpaw.Michelangelo.Utils, + Southpaw.AbbeyRoad.Capture, + Southpaw.Utilities.Utilities, Southpaw.Utilities.Format, Southpaw.Units.Units, + Southpaw.Unicode.WinUnicodeConIO, Southpaw.Unicode.UnicodeTest, + Southpaw.Cartesian.Cartesian, + Southpaw.Picasso.Palette, Southpaw.Picasso.RenderUtils, + Southpaw.Interactive.Application + --Southpaw.WaveFront.SampleApp, + + -- Modules included in this library but not exported. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + other-extensions: ForeignFunctionInterface, FlexibleInstances, CPP, NoImplicitPrelude + + -- Other library packages from which modules are imported. + build-depends: base >=4.7 && <4.8, + containers >=0.5 && <0.6, + Win32 >=2.3 && <2.4, + OpenGL, + GLFW-b, + filepath, + gtk3, + cairo, + bytestring, vector, + ALUT, OpenAL, + JuicyPixels >=3.2 + + -- Directories containing source files. + hs-source-dirs: lib + + -- Base language which the package is written in. + default-language: Haskell2010 +
+ lib/Southpaw/AbbeyRoad/Capture.hs view
@@ -0,0 +1,179 @@+-- | +-- Module : Southpaw.AbbeyRoad.Capture +-- Description : Microphone input +-- Copyright : (c) Jonatan H Sundqvist, 2015 +-- License : MIT +-- Maintainer : Jonatan H Sundqvist +-- Stability : experimental|stable +-- Portability : POSIX (not sure) +-- + +-- Created July 22 2015 +-- +-- I am forever indebted to the author of this module: https://github.com/peterhil/hs-openal-proto/blob/master/src/Sound/OpenAL/Proto/Play.hs +-- Saved me from having to figure out how to construct memory views by myself. + +-- TODO | - Proper error handling (IO exceptions, Either, or something else) +-- - Remove redundant imports +-- - Include the legal note from Peter's repo + +-- SPEC | - +-- - + + + +module Southpaw.AbbeyRoad.Capture where + + + +--------------------------------------------------------------------------------------------------- +-- We'll need these +--------------------------------------------------------------------------------------------------- +import Control.Concurrent (threadDelay) -- +import Control.Exception (bracket) -- +import Control.Monad (unless, when) -- + +import Data.Int -- +import Data.List (intersperse) -- +import Data.Word -- + +import GHC.Float (float2Double) -- + +import Foreign -- Import the foreigners! +import Foreign.C.Types -- +import Foreign.ForeignPtr -- +import Foreign.ForeignPtr.Unsafe -- +import Foreign.Ptr -- + +import Sound.ALUT -- + +import Sound.OpenAL -- +import Sound.OpenAL.AL.BasicTypes (ALsizei) -- +import Sound.OpenAL.ALC.Capture -- + +import System.Exit (exitFailure) -- +import System.IO (hPutStrLn, stderr, openBinaryFile, IOMode(ReadMode), hClose, hFileSize, hGetBuf) -- + +import qualified Data.Vector.Storable as V -- +import qualified Data.Vector.Storable.Mutable as VM -- + + + + +--------------------------------------------------------------------------------------------------- +-- Types +--------------------------------------------------------------------------------------------------- +type Sample = Double + + + +--------------------------------------------------------------------------------------------------- +-- Data +--------------------------------------------------------------------------------------------------- +samplerate = 44100 :: Int -- TODO: Don't hard-code sample rate + +mono8BufferSize = bufferSize 1 (undefined :: Word8) +mono16BufferSize = bufferSize 1 (undefined :: Int16) +stereo8BufferSize = bufferSize 2 (undefined :: Word8) +stereo16BufferSize = bufferSize 2 (undefined :: Int16) + + + +--------------------------------------------------------------------------------------------------- +-- Functions +--------------------------------------------------------------------------------------------------- + +-- | +bufferSize :: Storable a => Int -> a -> Double -> Int +bufferSize nchannels sampleType secs = fromIntegral (numSamples secs) * sizeOf sampleType * nchannels + + +-- | +numSamples :: Double -> NumSamples +numSamples secs = round (fromIntegral(samplerate) * secs) :: NumSamples + +--------------------------------------------------------------------------------------------------- + +-- | +sine :: Double -> [Sample] +sine freq = cycle $ take n $ map sin [0, d..] + where d = 2 * pi * freq / sr + n = truncate (sr / freq) + sr = fromIntegral samplerate + +--------------------------------------------------------------------------------------------------- + +-- | +pcm :: (Integral a) => Int -> Sample -> a +pcm bits sample = truncate $ sample * (fromIntegral (2 ^ (bits - 1)) - 1) + +--------------------------------------------------------------------------------------------------- + +-- | +-- # From http://dev.stephendiehl.com/hask/#ffi +vecPtr :: VM.MVector s CInt -> ForeignPtr CInt +vecPtr = fst . VM.unsafeToForeignPtr0 + +--------------------------------------------------------------------------------------------------- + +-- | +-- captureSamples :: Device -> Ptr a -> NumSamples -> IO () +-- allocaBytes :: Int -> (Ptr a -> IO b) -> IO b +-- allocaBytesAligned :: Int -> Int -> (Ptr a -> IO b) -> IO b +-- TODO: Find out why captureOpenDevice returns Nothing when secs is 0 +-- TODO: Pass in failure action (?) +-- TODO: Rename (eg. 'record' to 'startRecording') (?) +withCaptureDevice :: (Maybe String) -> Double -> (Device -> IO c) -> IO (Maybe c) +withCaptureDevice specifier secs onsuccess = bracket acquire finally between + where format = Mono16 + finally = maybe (return False) (\mic -> putStrLn "Closing device..." >> captureStop mic >> captureCloseDevice mic) + record mic = captureStart mic >> return mic + acquire = captureOpenDevice specifier (fromIntegral samplerate) format (numSamples secs) + between mmic = case mmic of + Just mic -> record mic >> onsuccess mic >>= return . Just + Nothing -> return Nothing + + +-- | +-- TODO: Refactor +-- capture :: V.Storable a => (Maybe String) -> Double -> IO (MemoryRegion a) +-- capture :: Storable a => (Maybe String) -> Double -> (MemoryRegion a -> IO c) -> IO c +-- capture :: (Maybe String) -> Double -> IO (V.Vector Int16) +capture :: Maybe String -> Double -> (MemoryRegion CInt -> IO c) -> IO (Maybe c) -- According to GHCi +capture specifier duration action = withCaptureDevice specifier duration record + where num = numSamples duration + record mic = do + sleep $ realToFrac duration -- Sleep until we should stop recording + mutableV <- V.thaw . V.fromList . map (pcm 16) . take (fromIntegral num) $ sine 220 -- + withForeignPtr (vecPtr mutableV) $ \ptr -> captureSamples mic ptr (fromIntegral num) -- + rec <- V.freeze mutableV -- + let (mem, size) = V.unsafeToForeignPtr0 rec -- + withForeignPtr mem $ \ptr -> action $ MemoryRegion ptr (fromIntegral size) -- + +--------------------------------------------------------------------------------------------------- + +-- | +checkAlErrors :: IO [String] +checkAlErrors = do + errs <- get $ alErrors + return [ d | ALError _ d <- errs ] + + +-- | +checkAlcErrors :: Device -> IO [String] +checkAlcErrors device = do + errs <- get $ alcErrors device + return [ d | ALCError _ d <- errs ] + +--------------------------------------------------------------------------------------------------- + +-- | +withFileContents :: FilePath -> (MemoryRegion a -> IO b) -> IO b +withFileContents filePath action = + bracket (openBinaryFile filePath ReadMode) hClose $ \handle -> do + numBytes <- fmap fromIntegral (hFileSize handle) + allocaBytes numBytes $ \buf -> do + bytesRead <- hGetBuf handle buf numBytes + when (bytesRead /= numBytes) $ + ioError (userError "hGetBuf") + action (MemoryRegion buf (fromIntegral numBytes))
+ lib/Southpaw/Cartesian/Cartesian.hs view
@@ -0,0 +1,128 @@+----------------------------------------------------------------------------- +-- | +-- Module : Cartesian.Cartesian +-- Copyright : (C) 2015 Jonatan H Sundqvist +-- License : MIT-style (see the file LICENSE) +-- Maintainer : Jonatan H Sundqvist <jonatanhsundqvist@gmail.com> +-- Stability : provisional +-- Portability : Portable +-- +-- Vector and coordinate system utilities. +----------------------------------------------------------------------------- + +-- +-- Cartesian.hs +-- This module exports the API for the Cartesian project +-- +-- Jonatan H Sundqvist +-- January 27 2015 +-- + +-- TODO | - Haddock header, sections, full coverage +-- - Separate 2D and 3D modules (?) + +-- SPEC | - +-- - + + + +module Southpaw.Cartesian.Cartesian where + + + +--------------------------------------------------------------------------------------------------- +-- We'll need these +--------------------------------------------------------------------------------------------------- +import Data.List (sort, minimumBy) +import Data.Ord (comparing) + + + +--------------------------------------------------------------------------------------------------- +-- Types +--------------------------------------------------------------------------------------------------- +data Vector num = Vector num num num -- TODO: Constraints on argument types (cf. GADT) (?) +data Line num = Line (Vector num) (Vector num) + + +vector :: Num a => a -> a -> a -> Vector a +vector = Vector -- SublimeHaskell prefers the eta-reduced version (point-free) + + + +--------------------------------------------------------------------------------------------------- +-- Instances +--------------------------------------------------------------------------------------------------- +instance Floating a => Num (Vector a) where + -- TODO: Helper method to reduce boilerplate for component-wise operations + (+) = dotWise (+) + (-) = dotWise (-) + (*) = dotWise (*) -- TODO: Is this really correct? + fromInteger n = Vector (fromInteger n) 0 0 + signum = id -- TODO: Proper way of implementing this function for vectors + -- abs a = Vector (euclidean a) 0 0 + -- abs (Vector x y z) = sqrt $ (x**2) + (y**2) + (z**2) + + + +--------------------------------------------------------------------------------------------------- +-- Functions +--------------------------------------------------------------------------------------------------- +-- | Performs component-wise operations +dotWise :: (a -> b -> c) -> Vector a -> Vector b -> Vector c +dotWise f (Vector x y z) (Vector x' y' z') = Vector (f x x') (f y y') (f z z') + + +-- | Dot product of two vectors +dot :: Floating a => Vector a -> Vector a -> a +dot (Vector x y z) (Vector x' y' z') = (x * x') + (y * y') + (z * z') -- TODO: Refactor with Num instance (?) + + +-- | Euclidean distance between two points +euclidean :: Floating a => Vector a -> Vector a -> a +euclidean a b = sqrt $ dot a b + + +-- | Intersect +-- TODO: Math notes, MathJax or LaTex +-- TODO: Intersect for curves and single points (?) +-- TODO: Polymorphic, typeclass (lines, shapes, ranges, etc.) (?) +intersect :: Num a => Line a -> Line a -> Maybe (Vector a) +intersect _ _ = Nothing + + +-- | Yields the overlap of two closed intervals (n ∈ R) +-- TODO: Normalise intervals (eg. (12, 5) -> (5, 12)) +overlap :: Real a => (a, a) -> (a, a) -> Maybe (a, a) +overlap a b + | leftmost /= (α, β) = Just $ (β, γ) -- + | otherwise = Nothing -- + where [α, β, γ, _] = sort [fst a, snd a, fst b, snd b] -- That's right. + leftmost = minimumBy (comparing fst) [a, b] -- + + +-- | +-- TODO: Intersect Rectangles + + + +-- | Coefficients for the linear function of a Line (slope, intercept). The Z-component is ignored. +-- Fails for vertical and horizontal lines. +-- +-- TODO: Use Maybe (?) +-- +coefficients :: (Fractional a, Eq a) => Line a -> Maybe (a, a) +coefficients (Line (Vector ax ay _) (Vector bx by _)) + | ax == bx = Nothing + | ay == ay = Nothing + | otherwise = let slope = (by - ay)/(bx - ax) in Just (slope, ay - slope*ax) + + + +--------------------------------------------------------------------------------------------------- +-- Entry point +--------------------------------------------------------------------------------------------------- +main :: IO () +main = do + putStrLn "Hello World" + putStrLn "Hola Mundo!"
+ lib/Southpaw/Interactive/Application.hs view
@@ -0,0 +1,87 @@+-- | +-- Module : Application +-- Description : Utilties for creating GUI applications +-- Copyright : (c) Jonatan H Sundqvist, year +-- License : MIT +-- Maintainer : Jonatan H Sundqvist +-- Stability : experimental|stable +-- Portability : POSIX (not sure) +-- + +-- Created date year + +-- TODO | - +-- - + +-- SPEC | - +-- - + + + +module Southpaw.Interactive.Application where + + + +--------------------------------------------------------------------------------------------------- +-- We'll need these +--------------------------------------------------------------------------------------------------- +import Graphics.UI.Gtk -- +import Data.IORef -- +-- import Graphics.Rendering.Cairo -- + + + +--------------------------------------------------------------------------------------------------- +-- Types +--------------------------------------------------------------------------------------------------- +-- | +-- TODO: Input state (?) +data App state = App { _window :: Window, _canvas :: DrawingArea, _size :: (Int, Int), _state :: IORef state } -- +-- data AppState = AppState { _game :: Game, _selected :: Maybe Int, _path :: [Complex Double] } -- + + + +--------------------------------------------------------------------------------------------------- +-- Data +--------------------------------------------------------------------------------------------------- + + + +--------------------------------------------------------------------------------------------------- +-- Functions +--------------------------------------------------------------------------------------------------- +--------------------------------------------------------------------------------------------------- +-- | +-- TODO: Make polymorphic +widgetSize :: WidgetClass self => self -> IO (Int, Int) +widgetSize widget = do + w <- widgetGetAllocatedWidth widget + h <- widgetGetAllocatedHeight widget + return (w, h) + + +-- | +createWindowWithCanvas :: Int -> Int -> appstate -> IO (App appstate) +createWindowWithCanvas w h appstate = do + -- + initGUI + window <- windowNew + + frame <- frameNew + canvas <- drawingAreaNew + containerAdd frame canvas + + set window [ containerChild := frame ] + windowSetDefaultSize window w h + + widgetAddEvents canvas [PointerMotionMask] -- MouseButton1Mask + + widgetShowAll window + + -- Animation + size <- widgetSize window + + -- + stateref <- newIORef appstate + + return $ App window canvas size stateref
+ lib/Southpaw/Michelangelo/Utils.hs view
@@ -0,0 +1,105 @@+-- | +-- Module : Southpaw.Michelangelo.Utils +-- Description : Utilities for doing 3D graphics with OpenGL +-- Copyright : (c) Jonatan H Sundqvist, 2015 +-- License : MIT +-- Maintainer : Jonatan H Sundqvist +-- Stability : experimental|stable +-- Portability : POSIX (not sure) +-- + +-- Created July 20 2015 +-- Adapted from http://hackage.haskell.org/package/scenegraph-0.1.0.1/docs/src/Graphics-SceneGraph-Textures.html#getAndCreateTextures + +-- TODO | - +-- - + +-- SPEC | - +-- - + + + +module Southpaw.Michelangelo.Utils where + + + +--------------------------------------------------------------------------------------------------- +-- We'll need these +--------------------------------------------------------------------------------------------------- +-- import Graphics.UI.GLUT +-- import Graphics.SceneGraph.ReadImage (readImage) +-- import Graphics.SceneGraph.TGA +import Codec.Picture +import Control.Monad (when) +import Data.Word +-- import Foreign.Marshal.Alloc + +import qualified Data.ByteString as BS + + + +--------------------------------------------------------------------------------------------------- +-- Functions +--------------------------------------------------------------------------------------------------- +-- | +saveImage :: FilePath -> BS.ByteString -> IO () +saveImage fn image = BS.writeFile fn image + + +-- | +-- createTexture :: Size -> PixelData Int -> IO (Maybe TextureObject) +-- createTexture (Size cx cy) pixels = do +-- [tex] <- genObjectNames 1 -- +-- textureBinding Texture2D $= Just tex -- +-- build2DMipmaps Texture2D RGBA' (fromIntegral cx) (fromIntegral cy) pixels +-- textureFilter Texture2D $= ((Linear', Just Nearest), Linear') +-- textureFunction $= Modulate +-- -- free ptr +-- return $ Just tex + + +-- | +-- createTextures :: [(Size, PixelData Int)] -> IO [Maybe TextureObject] +-- createTextures fn = return + + +-- -- read a list of images and returns a list of textures +-- -- all images are assumed to be in the TGA image format +-- getAndCreateTextures :: [String] -> IO [Maybe TextureObject] +-- getAndCreateTextures fileNames = do +-- fileNamesExts <- return (map (++".tga") fileNames) +-- texData <- mapM readImageC fileNamesExts +-- texObjs <- mapM createTexture texData +-- return texObjs + + +-- -- read a single texture +-- getAndCreateTexture :: String -> IO (Maybe TextureObject) +-- getAndCreateTexture fileName = do +-- texData <- readImageC (fileName++".tga") +-- texObj <- createTexture texData +-- return texObj + + +-- -- read the image data +-- readImageC :: String -> IO (Maybe (Size, PixelData Word8)) +-- readImageC path = catch (readTga path) (\err -> do +-- print ("missing texture: "++path) +-- return Nothing) + + +-- -- creates the texture +-- createTexture :: (Maybe (Size, PixelData a)) -> IO (Maybe TextureObject) +-- createTexture (Just ((Size x y), pixels@(PixelData t1 t2 ptr))) = do +-- [texName] <- genObjectNames 1 -- generate our texture. +-- --rowAlignment Unpack $= 1 +-- textureBinding Texture2D $= Just texName -- make our new texture the current texture. +-- --generateMipmap Texture2D $= Enabled +-- build2DMipmaps Texture2D RGBA' (fromIntegral x) (fromIntegral y) pixels +-- textureFilter Texture2D $= ((Linear', Just Nearest), Linear') +-- --textureWrapMode Texture2D S $= (Repeated, Repeat) +-- --textureWrapMode Texture2D T $= (Repeated, Repeat) +-- textureFunction $= Modulate +-- free ptr +-- return (Just texName) +-- createTexture Nothing = return Nothing
+ lib/Southpaw/Picasso/Palette.hs view
@@ -0,0 +1,253 @@+-- | +-- Module : Palette +-- Description : Colours for Cairo +-- Copyright : (c) Jonatan H Sundqvist, 2015 +-- License : MIT +-- Maintainer : Jonatan H Sundqvist +-- Stability : experimental +-- Portability : POSIX (not sure) +-- +-- Jonatan H Sundqvist +-- June 11 2015 +-- + +-- TODO | - Polymorphic colours (?) +-- - + +-- SPEC | - +-- - + + + +--------------------------------------------------------------------------------------------------- +-- Pragmas +--------------------------------------------------------------------------------------------------- +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} + + + +--------------------------------------------------------------------------------------------------- +-- API definition +--------------------------------------------------------------------------------------------------- +module Southpaw.Picasso.Palette where + + + +--------------------------------------------------------------------------------------------------- +-- We'll need these +--------------------------------------------------------------------------------------------------- +import qualified Graphics.Rendering.Cairo as Cairo + + + +--------------------------------------------------------------------------------------------------- +-- Types +--------------------------------------------------------------------------------------------------- +type Colour = (Double, Double, Double, Double) + + + +--------------------------------------------------------------------------------------------------- +-- Colours +--------------------------------------------------------------------------------------------------- +black = (0, 0, 0, 1) :: Colour +white = (1, 1, 1, 1) :: Colour + +red = (1, 0, 0, 1) :: Colour +green = (0, 1, 0, 1) :: Colour +blue = (0, 0, 1, 1) :: Colour + +-- From http://www.avatar.se/molscript/doc/colour_names.html (June 11 2015) +aliceblue = (0.94117600, 0.97254900, 1.00000000, 1) :: Colour +antiquewhite = (0.98039200, 0.92156900, 0.84313700, 1) :: Colour +aquamarine = (0.49803900, 1.00000000, 0.83137300, 1) :: Colour +azure = (0.94117600, 1.00000000, 1.00000000, 1) :: Colour +beige = (0.96078400, 0.96078400, 0.86274500, 1) :: Colour +bisque = (1.00000000, 0.89411800, 0.76862700, 1) :: Colour +blanchedalmond = (1.00000000, 0.92156900, 0.80392200, 1) :: Colour +blueviolet = (0.54117600, 0.16862700, 0.88627500, 1) :: Colour +brown = (0.64705900, 0.16470600, 0.16470600, 1) :: Colour +burlywood = (0.87058800, 0.72156900, 0.52941200, 1) :: Colour +cadetblue = (0.37254900, 0.61960800, 0.62745100, 1) :: Colour +chartreuse = (0.49803900, 1.00000000, 0.00000000, 1) :: Colour +chocolate = (0.82352900, 0.41176500, 0.11764700, 1) :: Colour +coral = (1.00000000, 0.49803900, 0.31372500, 1) :: Colour +cornflowerblue = (0.39215700, 0.58431400, 0.92941200, 1) :: Colour +cornsilk = (1.00000000, 0.97254900, 0.86274500, 1) :: Colour +crimson = (0.86274500, 0.07843140, 0.23529400, 1) :: Colour +cyan = (0.00000000, 1.00000000, 1.00000000, 1) :: Colour +darkblue = (0.00000000, 0.00000000, 0.54509800, 1) :: Colour +darkcyan = (0.00000000, 0.54509800, 0.54509800, 1) :: Colour +darkgoldenrod = (0.72156900, 0.52549000, 0.04313730, 1) :: Colour +darkgray = (0.66274500, 0.66274500, 0.66274500, 1) :: Colour +darkgreen = (0.00000000, 0.39215700, 0.00000000, 1) :: Colour +darkgrey = (0.66274500, 0.66274500, 0.66274500, 1) :: Colour +darkkhaki = (0.74117600, 0.71764700, 0.41960800, 1) :: Colour +darkmagenta = (0.54509800, 0.00000000, 0.54509800, 1) :: Colour +darkolivegreen = (0.33333300, 0.41960800, 0.18431400, 1) :: Colour +darkorange = (1.00000000, 0.54902000, 0.00000000, 1) :: Colour +darkorchid = (0.60000000, 0.19607800, 0.80000000, 1) :: Colour +darkred = (0.54509800, 0.00000000, 0.00000000, 1) :: Colour +darksalmon = (0.91372500, 0.58823500, 0.47843100, 1) :: Colour +darkseagreen = (0.56078400, 0.73725500, 0.56078400, 1) :: Colour +darkslateblue = (0.28235300, 0.23921600, 0.54509800, 1) :: Colour +darkslategray = (0.18431400, 0.30980400, 0.30980400, 1) :: Colour +darkslategrey = (0.18431400, 0.30980400, 0.30980400, 1) :: Colour +darkturquoise = (0.00000000, 0.80784300, 0.81960800, 1) :: Colour +darkviolet = (0.58039200, 0.00000000, 0.82745100, 1) :: Colour +deeppink = (1.00000000, 0.07843140, 0.57647100, 1) :: Colour +deepskyblue = (0.00000000, 0.74902000, 1.00000000, 1) :: Colour +dimgray = (0.41176500, 0.41176500, 0.41176500, 1) :: Colour +dimgrey = (0.41176500, 0.41176500, 0.41176500, 1) :: Colour +dodgerblue = (0.11764700, 0.56470600, 1.00000000, 1) :: Colour +firebrick = (0.69803900, 0.13333300, 0.13333300, 1) :: Colour +floralwhite = (1.00000000, 0.98039200, 0.94117600, 1) :: Colour +forestgreen = (0.13333300, 0.54509800, 0.13333300, 1) :: Colour +gainsboro = (0.86274500, 0.86274500, 0.86274500, 1) :: Colour +ghostwhite = (0.97254900, 0.97254900, 1.00000000, 1) :: Colour +gold = (1.00000000, 0.84313700, 0.00000000, 1) :: Colour +goldenrod = (0.85490200, 0.64705900, 0.12549000, 1) :: Colour +gray = (0.74509800, 0.74509800, 0.74509800, 1) :: Colour +greenyellow = (0.67843100, 1.00000000, 0.18431400, 1) :: Colour +grey = (0.74509800, 0.74509800, 0.74509800, 1) :: Colour +honeydew = (0.94117600, 1.00000000, 0.94117600, 1) :: Colour +hotpink = (1.00000000, 0.41176500, 0.70588200, 1) :: Colour +indianred = (0.80392200, 0.36078400, 0.36078400, 1) :: Colour +indigo = (0.29411800, 0.00000000, 0.50980400, 1) :: Colour +ivory = (1.00000000, 1.00000000, 0.94117600, 1) :: Colour +khaki = (0.94117600, 0.90196100, 0.54902000, 1) :: Colour +lavender = (0.90196100, 0.90196100, 0.98039200, 1) :: Colour +lavenderblush = (1.00000000, 0.94117600, 0.96078400, 1) :: Colour +lawngreen = (0.48627500, 0.98823500, 0.00000000, 1) :: Colour +lemonchiffon = (1.00000000, 0.98039200, 0.80392200, 1) :: Colour +lightblue = (0.67843100, 0.84705900, 0.90196100, 1) :: Colour +lightcoral = (0.94117600, 0.50196100, 0.50196100, 1) :: Colour +lightcyan = (0.87843100, 1.00000000, 1.00000000, 1) :: Colour +lightgoldenrod = (0.93333300, 0.86666700, 0.50980400, 1) :: Colour +lightgoldenrodyellow = (0.98039200, 0.98039200, 0.82352900, 1) :: Colour +lightgray = (0.82745100, 0.82745100, 0.82745100, 1) :: Colour +lightgreen = (0.56470600, 0.93333300, 0.56470600, 1) :: Colour +lightgrey = (0.82745100, 0.82745100, 0.82745100, 1) :: Colour +lightpink = (1.00000000, 0.71372500, 0.75686300, 1) :: Colour +lightsalmon = (1.00000000, 0.62745100, 0.47843100, 1) :: Colour +lightseagreen = (0.12549000, 0.69803900, 0.66666700, 1) :: Colour +lightskyblue = (0.52941200, 0.80784300, 0.98039200, 1) :: Colour +lightslateblue = (0.51764700, 0.43921600, 1.00000000, 1) :: Colour +lightslategray = (0.46666700, 0.53333300, 0.60000000, 1) :: Colour +lightslategrey = (0.46666700, 0.53333300, 0.60000000, 1) :: Colour +lightsteelblue = (0.69019600, 0.76862700, 0.87058800, 1) :: Colour +lightyellow = (1.00000000, 1.00000000, 0.87843100, 1) :: Colour +limegreen = (0.19607800, 0.80392200, 0.19607800, 1) :: Colour +linen = (0.98039200, 0.94117600, 0.90196100, 1) :: Colour +magenta = (1.00000000, 0.00000000, 1.00000000, 1) :: Colour +maroon = (0.69019600, 0.18823500, 0.37647100, 1) :: Colour +mediumaquamarine = (0.40000000, 0.80392200, 0.66666700, 1) :: Colour +mediumblue = (0.00000000, 0.00000000, 0.80392200, 1) :: Colour +mediumorchid = (0.72941200, 0.33333300, 0.82745100, 1) :: Colour +mediumpurple = (0.57647100, 0.43921600, 0.85882400, 1) :: Colour +mediumseagreen = (0.23529400, 0.70196100, 0.44313700, 1) :: Colour +mediumslateblue = (0.48235300, 0.40784300, 0.93333300, 1) :: Colour +mediumspringgreen = (0.00000000, 0.98039200, 0.60392200, 1) :: Colour +mediumturquoise = (0.28235300, 0.81960800, 0.80000000, 1) :: Colour +mediumvioletred = (0.78039200, 0.08235290, 0.52156900, 1) :: Colour +midnightblue = (0.09803920, 0.09803920, 0.43921600, 1) :: Colour +mintcream = (0.96078400, 1.00000000, 0.98039200, 1) :: Colour +mistyrose = (1.00000000, 0.89411800, 0.88235300, 1) :: Colour +moccasin = (1.00000000, 0.89411800, 0.70980400, 1) :: Colour +navajowhite = (1.00000000, 0.87058800, 0.67843100, 1) :: Colour +navy = (0.00000000, 0.00000000, 0.50196100, 1) :: Colour +navyblue = (0.00000000, 0.00000000, 0.50196100, 1) :: Colour +oldlace = (0.99215700, 0.96078400, 0.90196100, 1) :: Colour +olivedrab = (0.41960800, 0.55686300, 0.13725500, 1) :: Colour +orange = (1.00000000, 0.64705900, 0.00000000, 1) :: Colour +orangered = (1.00000000, 0.27058800, 0.00000000, 1) :: Colour +orchid = (0.85490200, 0.43921600, 0.83921600, 1) :: Colour +palegoldenrod = (0.93333300, 0.90980400, 0.66666700, 1) :: Colour +palegreen = (0.59607800, 0.98431400, 0.59607800, 1) :: Colour +paleturquoise = (0.68627500, 0.93333300, 0.93333300, 1) :: Colour +palevioletred = (0.85882400, 0.43921600, 0.57647100, 1) :: Colour +papayawhip = (1.00000000, 0.93725500, 0.83529400, 1) :: Colour +peachpuff = (1.00000000, 0.85490200, 0.72549000, 1) :: Colour +peru = (0.80392200, 0.52156900, 0.24705900, 1) :: Colour +pink = (1.00000000, 0.75294100, 0.79607800, 1) :: Colour +plum = (0.86666700, 0.62745100, 0.86666700, 1) :: Colour +powderblue = (0.69019600, 0.87843100, 0.90196100, 1) :: Colour +purple = (0.62745100, 0.12549000, 0.94117600, 1) :: Colour +rosybrown = (0.73725500, 0.56078400, 0.56078400, 1) :: Colour +royalblue = (0.25490200, 0.41176500, 0.88235300, 1) :: Colour +saddlebrown = (0.54509800, 0.27058800, 0.07450980, 1) :: Colour +salmon = (0.98039200, 0.50196100, 0.44705900, 1) :: Colour +sandybrown = (0.95686300, 0.64313700, 0.37647100, 1) :: Colour +seagreen = (0.18039200, 0.54509800, 0.34117600, 1) :: Colour +seashell = (1.00000000, 0.96078400, 0.93333300, 1) :: Colour +sgibeet = (0.55686300, 0.21960800, 0.55686300, 1) :: Colour +sgibrightgray = (0.77254900, 0.75686300, 0.66666700, 1) :: Colour +sgibrightgrey = (0.77254900, 0.75686300, 0.66666700, 1) :: Colour +sgichartreuse = (0.44313700, 0.77647100, 0.44313700, 1) :: Colour +sgidarkgray = (0.33333300, 0.33333300, 0.33333300, 1) :: Colour +sgidarkgrey = (0.33333300, 0.33333300, 0.33333300, 1) :: Colour +sgilightblue = (0.49019600, 0.61960800, 0.75294100, 1) :: Colour +sgilightgray = (0.66666700, 0.66666700, 0.66666700, 1) :: Colour +sgilightgrey = (0.66666700, 0.66666700, 0.66666700, 1) :: Colour +sgimediumgray = (0.51764700, 0.51764700, 0.51764700, 1) :: Colour +sgimediumgrey = (0.51764700, 0.51764700, 0.51764700, 1) :: Colour +sgiolivedrab = (0.55686300, 0.55686300, 0.21960800, 1) :: Colour +sgisalmon = (0.77647100, 0.44313700, 0.44313700, 1) :: Colour +sgislateblue = (0.44313700, 0.44313700, 0.77647100, 1) :: Colour +sgiteal = (0.21960800, 0.55686300, 0.55686300, 1) :: Colour +sgiverydarkgray = (0.15686300, 0.15686300, 0.15686300, 1) :: Colour +sgiverydarkgrey = (0.15686300, 0.15686300, 0.15686300, 1) :: Colour +sgiverylightgray = (0.83921600, 0.83921600, 0.83921600, 1) :: Colour +sgiverylightgrey = (0.83921600, 0.83921600, 0.83921600, 1) :: Colour +sienna = (0.62745100, 0.32156900, 0.17647100, 1) :: Colour +skyblue = (0.52941200, 0.80784300, 0.92156900, 1) :: Colour +slateblue = (0.41568600, 0.35294100, 0.80392200, 1) :: Colour +slategray = (0.43921600, 0.50196100, 0.56470600, 1) :: Colour +slategrey = (0.43921600, 0.50196100, 0.56470600, 1) :: Colour +snow = (1.00000000, 0.98039200, 0.98039200, 1) :: Colour +springgreen = (0.00000000, 1.00000000, 0.49803900, 1) :: Colour +steelblue = (0.27451000, 0.50980400, 0.70588200, 1) :: Colour +-- tan = (0.82352900, 0.70588200, 0.54902000, 1) :: Colour +thistle = (0.84705900, 0.74902000, 0.84705900, 1) :: Colour +tomato = (1.00000000, 0.38823500, 0.27843100, 1) :: Colour +turquoise = (0.25098000, 0.87843100, 0.81568600, 1) :: Colour +violet = (0.93333300, 0.50980400, 0.93333300, 1) :: Colour +violetred = (0.81568600, 0.12549000, 0.56470600, 1) :: Colour +wheat = (0.96078400, 0.87058800, 0.70196100, 1) :: Colour +whitesmoke = (0.96078400, 0.96078400, 0.96078400, 1) :: Colour +yellow = (1.00000000, 1.00000000, 0.00000000, 1) :: Colour +yellowgreen = (0.60392200, 0.80392200, 0.19607800, 1) :: Colour + + + +--------------------------------------------------------------------------------------------------- +-- Functions +--------------------------------------------------------------------------------------------------- +-- | +choose :: Colour -> Cairo.Render () +choose (r, g, b, a) = Cairo.setSourceRGBA r g b a + + +-- | +blend :: Colour -> Colour -> Colour +blend (r, g, b, a) (r', g', b', a') = ((r+r')/2, (g+g')/2, (b+b')/2, (a+a')/2) + + +-- Lenses ----------------------------------------------------------------------------------------- +-- | +-- TODO: Clamp (?) +-- TODO: Use proper lenses instead (?) +withRed :: Colour -> (Double -> Double) -> Colour +withRed (r, g, b, a) f = (f r, g, b, a) + + +withGreen :: Colour -> (Double -> Double) -> Colour +withGreen (r, g, b, a) f = (r, f g, b, a) + + +withBlue :: Colour -> (Double -> Double) -> Colour +withBlue (r, g, b, a) f = (r, g, f b, a) + + +withAlpha :: Colour -> (Double -> Double) -> Colour +withAlpha (r, g, b, a) f = (r, g, b, f a)
+ lib/Southpaw/Picasso/RenderUtils.hs view
@@ -0,0 +1,44 @@+-- | +-- Module : RenderUtils +-- Description : Cairo rendering utilities +-- Copyright : (c) Jonatan H Sundqvist, 2015 +-- License : MIT +-- Maintainer : Jonatan H Sundqvist +-- Stability : experimental|stable +-- Portability : POSIX (not sure) +-- + +-- Created July 12 2015 + +-- TODO | - +-- - + +-- SPEC | - +-- - + + + +module Southpaw.Picasso.RenderUtils (renderCentredText) where + + + +--------------------------------------------------------------------------------------------------- +-- We'll need these +--------------------------------------------------------------------------------------------------- +import qualified Graphics.Rendering.Cairo as Cairo +import Data.Complex + + + +--------------------------------------------------------------------------------------------------- +-- Functions +--------------------------------------------------------------------------------------------------- +-- General rendering utilities -------------------------------------------------------------------- +-- | +-- TODO: General anchor (?) +renderCentredText :: Complex Double -> String -> Cairo.Render () +renderCentredText (cx:+cy) text = do + extents <- Cairo.textExtents text + let (w, h) = (Cairo.textExtentsWidth extents, Cairo.textExtentsHeight extents) + Cairo.moveTo (cx-w/2) (cy+h/2) + Cairo.showText text
+ lib/Southpaw/Unicode/UnicodeTest.hs view
@@ -0,0 +1,27 @@+-- +-- Name +-- UnicodeTest.hs +-- +-- Description +-- Testing the Windows Unicode module found in this directory +-- +-- Author +-- Jonatan H Sundqvist +-- +-- Date +-- August 10 2014 +-- + +-- NOTE +-- This solution may be redundant +-- (cf. utf8-string) + +{-# LANGUAGE NoImplicitPrelude #-} + +module Southpaw.Unicode.UnicodeTest where + +import qualified Southpaw.Unicode.WinUnicodeConIO as Unicode + +main = do + Unicode.putStr "♔♕♖♗♘♙|♚♛♜♝♞♟" + Unicode.getChar
+ lib/Southpaw/Unicode/WinUnicodeConIO.hs view
@@ -0,0 +1,220 @@+-- +-- Name +-- WinUnicodeConIO (orig. IOUtil) +-- +-- Description +-- Workaround for Unicode console output on Windows +-- +-- Credits +-- http://stackoverflow.com/questions/10779149/unicode-console-i-o-in-haskell-on-windows +-- +-- Date +-- August 10 2014 +-- + + +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE NoImplicitPrelude #-} + + +module Southpaw.Unicode.WinUnicodeConIO ( + Southpaw.Unicode.WinUnicodeConIO.interact, + Southpaw.Unicode.WinUnicodeConIO.putChar, Southpaw.Unicode.WinUnicodeConIO.putStr, Southpaw.Unicode.WinUnicodeConIO.putStrLn, Southpaw.Unicode.WinUnicodeConIO.print, + Southpaw.Unicode.WinUnicodeConIO.getChar, Southpaw.Unicode.WinUnicodeConIO.getLine, Southpaw.Unicode.WinUnicodeConIO.getContents, Southpaw.Unicode.WinUnicodeConIO.readIO, + Southpaw.Unicode.WinUnicodeConIO.readLn, + ePutChar, ePutStr, ePutStrLn, ePrint, + trace, traceIO + ) where + +#ifdef mingw32_HOST_OS + +import System.Win32.Types (BOOL, HANDLE, DWORD, LPDWORD, LPWSTR, LPCWSTR, LPVOID) +import Foreign.C.Types (CWchar) +import Foreign +import Prelude hiding (getContents, putStr, putStrLn) --(IO, Read, Show, String) +--import qualified System.IO +import qualified System.IO (getContents) +import System.IO hiding (getContents, putStr, putStrLn) +import System.IO.Unsafe (unsafePerformIO) +import Data.Char (ord) + + {- <http://msdn.microsoft.com/en-us/library/ms683231(VS.85).aspx> + HANDLE WINAPI GetStdHandle(DWORD nStdHandle); + returns INVALID_HANDLE_VALUE, NULL, or a valid handle -} + +foreign import stdcall unsafe "GetStdHandle" win32GetStdHandle :: DWORD -> IO (HANDLE) + +std_OUTPUT_HANDLE = -11 :: DWORD -- all DWORD arithmetic is performed modulo 2^n +std_ERROR_HANDLE = -12 :: DWORD + + {- <http://msdn.microsoft.com/en-us/library/aa364960(VS.85).aspx> + DWORD WINAPI GetFileType(HANDLE hFile); -} + +foreign import stdcall unsafe "GetFileType" win32GetFileType :: HANDLE -> IO (DWORD) +_FILE_TYPE_CHAR = 0x0002 :: DWORD +_FILE_TYPE_REMOTE = 0x8000 :: DWORD + + {- <http://msdn.microsoft.com/en-us/library/ms683167(VS.85).aspx> + BOOL WINAPI GetConsoleMode(HANDLE hConsole, LPDWORD lpMode); -} + +foreign import stdcall unsafe "GetConsoleMode" win32GetConsoleMode :: HANDLE -> LPDWORD -> IO (BOOL) +_INVALID_HANDLE_VALUE = (intPtrToPtr $ -1) :: HANDLE + +is_a_console :: HANDLE -> IO (Bool) +is_a_console handle + = if (handle == _INVALID_HANDLE_VALUE) then return False + else do ft <- win32GetFileType handle + if ((ft .&. complement _FILE_TYPE_REMOTE) /= _FILE_TYPE_CHAR) then return False + else do ptr <- malloc + cm <- win32GetConsoleMode handle ptr + free ptr + return cm + +real_stdout :: IO (Bool) +real_stdout = is_a_console =<< win32GetStdHandle std_OUTPUT_HANDLE + +real_stderr :: IO (Bool) +real_stderr = is_a_console =<< win32GetStdHandle std_ERROR_HANDLE + + {- BOOL WINAPI WriteConsoleW(HANDLE hOutput, LPWSTR lpBuffer, DWORD nChars, + LPDWORD lpCharsWritten, LPVOID lpReserved); -} + +foreign import stdcall unsafe "WriteConsoleW" win32WriteConsoleW + :: HANDLE -> LPWSTR -> DWORD -> LPDWORD -> LPVOID -> IO (BOOL) + +data ConsoleInfo = ConsoleInfo Int (Ptr CWchar) (Ptr DWORD) HANDLE + +writeConsole :: ConsoleInfo -> [Char] -> IO () +writeConsole (ConsoleInfo bufsize buf written handle) string + = let fillbuf :: Int -> [Char] -> IO () + fillbuf i [] = emptybuf buf i [] + fillbuf i remain@(first:rest) + | i + 1 < bufsize && ordf <= 0xffff = do pokeElemOff buf i asWord + fillbuf (i+1) rest + | i + 1 < bufsize && ordf > 0xffff = do pokeElemOff buf i word1 + pokeElemOff buf (i+1) word2 + fillbuf (i+2) rest + | otherwise = emptybuf buf i remain + where ordf = ord first + asWord = fromInteger (toInteger ordf) :: CWchar + sub = ordf - 0x10000 + word1' = ((shiftR sub 10) .&. 0x3ff) + 0xD800 + word2' = (sub .&. 0x3FF) + 0xDC00 + word1 = fromInteger . toInteger $ word1' + word2 = fromInteger . toInteger $ word2' + + + emptybuf :: (Ptr CWchar) -> Int -> [Char] -> IO () + emptybuf _ 0 [] = return () + emptybuf _ 0 remain = fillbuf 0 remain + emptybuf ptr nLeft remain + = do let nLeft' = fromInteger . toInteger $ nLeft + ret <- win32WriteConsoleW handle ptr nLeft' written nullPtr + nWritten <- peek written + let nWritten' = fromInteger . toInteger $ nWritten + if ret && (nWritten > 0) + then emptybuf (ptr `plusPtr` (nWritten' * szWChar)) (nLeft - nWritten') remain + else fail "WriteConsoleW failed.\n" + + in fillbuf 0 string + +szWChar = sizeOf (0 :: CWchar) + +makeConsoleInfo :: DWORD -> Handle -> IO (Either ConsoleInfo Handle) +makeConsoleInfo nStdHandle fallback + = do handle <- win32GetStdHandle nStdHandle + is_console <- is_a_console handle + let bufsize = 10000 + if not is_console then return $ Right fallback + else do buf <- mallocBytes (szWChar * bufsize) + written <- malloc + return . Left $ ConsoleInfo bufsize buf written handle + +{-# NOINLINE stdoutConsoleInfo #-} +stdoutConsoleInfo :: Either ConsoleInfo Handle +stdoutConsoleInfo = unsafePerformIO $ makeConsoleInfo std_OUTPUT_HANDLE stdout + +{-# NOINLINE stderrConsoleInfo #-} +stderrConsoleInfo :: Either ConsoleInfo Handle +stderrConsoleInfo = unsafePerformIO $ makeConsoleInfo std_ERROR_HANDLE stderr + +interact :: (String -> String) -> IO () +interact f = do s <- getContents + putStr (f s) + +conPutChar ci = writeConsole ci . replicate 1 +conPutStr = writeConsole +conPutStrLn ci = writeConsole ci . ( ++ "\n") + +putChar :: Char -> IO () +putChar = (either conPutChar hPutChar ) stdoutConsoleInfo + +putStr :: String -> IO () +putStr = (either conPutStr hPutStr ) stdoutConsoleInfo + +putStrLn :: String -> IO () +putStrLn = (either conPutStrLn hPutStrLn) stdoutConsoleInfo + +print :: Show a => a -> IO () +print = putStrLn . show + +getChar = System.IO.getChar +getLine = System.IO.getLine +getContents = System.IO.getContents + +readIO :: Read a => String -> IO a +readIO = System.IO.readIO + +readLn :: Read a => IO a +readLn = System.IO.readLn + +ePutChar :: Char -> IO () +ePutChar = (either conPutChar hPutChar ) stderrConsoleInfo + +ePutStr :: String -> IO () +ePutStr = (either conPutStr hPutStr ) stderrConsoleInfo + +ePutStrLn :: String -> IO () +ePutStrLn = (either conPutStrLn hPutStrLn) stderrConsoleInfo + +ePrint :: Show a => a -> IO () +ePrint = ePutStrLn . show + +#else + +import qualified System.IO +import Prelude (IO, Read, Show, String) + +interact = System.IO.interact +putChar = System.IO.putChar +putStr = System.IO.putStr +putStrLn = System.IO.putStrLn +getChar = System.IO.getChar +getLine = System.IO.getLine +getContents = System.IO.getContents +ePutChar = System.IO.hPutChar System.IO.stderr +ePutStr = System.IO.hPutStr System.IO.stderr +ePutStrLn = System.IO.hPutStrLn System.IO.stderr + +print :: Show a => a -> IO () +print = System.IO.print + +readIO :: Read a => String -> IO a +readIO = System.IO.readIO + +readLn :: Read a => IO a +readLn = System.IO.readLn + +ePrint :: Show a => a -> IO () +ePrint = System.IO.hPrint System.IO.stderr + +#endif + +trace :: String -> a -> a +trace string expr = unsafePerformIO $ do + traceIO string + return expr + +traceIO :: String -> IO () +traceIO = ePutStrLn
+ lib/Southpaw/Units/Units.hs view
@@ -0,0 +1,27 @@+-- | +-- Module : Units +-- Description : Typechecked SI-units +-- Copyright : (c) Jonatan H Sundqvist, 2015 +-- License : MIT +-- Maintainer : Jonatan H Sundqvist +-- Stability : experimental +-- Portability : POSIX (not sure) +-- + +-- Created June 4 2015 + +-- TODO | - +-- - + +-- SPEC | - +-- - + + + +module Southpaw.Units.Units where + + + +--------------------------------------------------------------------------------------------------- +-- We'll need these +---------------------------------------------------------------------------------------------------
+ lib/Southpaw/Utilities/Format.hs view
@@ -0,0 +1,72 @@+-- +-- Format.hs +-- Experimental printf-style formatting +-- +-- Jonatan H Sundqvist +-- February 14 2015 +-- + +-- TODO | - +-- - + +-- SPEC | - +-- - + + + +{-# LANGUAGE FlexibleInstances #-} + + + +module Southpaw.Utilities.Format where + + + +--------------------------------------------------------------------------------------------------- +-- Text formatting +--------------------------------------------------------------------------------------------------- +-- | +-- TODO: Rename (?) +newtype FShow a = FShow a + + +-- | +-- TODO: Rename (?) +class Formattable a where + interpolate :: String -> a -> [Char] + + +-- | +-- TODO: Rename (?) +instance Show a => Formattable (FShow a) where + interpolate f (FShow a) = show a + + +instance (Formattable a, Formattable b) => Formattable (a -> b) where + interpolate f a = "Hello" + + +instance Formattable a => Formattable (a -> [Char]) where + interpolate f a = "Hello" + + + +-- format :: Formattable a => String -> a +-- format f a = interpolate f a + + + +--------------------------------------------------------------------------------------------------- +-- Section +--------------------------------------------------------------------------------------------------- +-- data Tuple a b = Head a | + + + +--------------------------------------------------------------------------------------------------- +-- Entry point +--------------------------------------------------------------------------------------------------- +main :: IO () +main = do + putStrLn "" + putStrLn ""
+ lib/Southpaw/Utilities/Utilities.hs view
@@ -0,0 +1,141 @@+-- +-- Utilities.hs +-- ? +-- +-- Jonatan H Sundqvist +-- March 08 2015 +-- + +-- TODO | - +-- - + +-- SPEC | - +-- - +-- | +-- Module : Southpaw.Utilities.Utilities +-- Description : General functional bits and bobs +-- Copyright : (c) Jonatan H Sundqvist, year +-- License : MIT +-- Maintainer : Jonatan H Sundqvist +-- Stability : experimental|stable +-- Portability : POSIX (not sure) +-- + +-- Created March 08 2015 + +-- TODO | - +-- - + +-- SPEC | - +-- - + + + +module Southpaw.Utilities.Utilities (thousands, abbreviate, chunks, numeral, split, pairwise, cuts, count) where + + + +--------------------------------------------------------------------------------------------------- +-- We'll need these +--------------------------------------------------------------------------------------------------- +import Data.List (intercalate, unfoldr) + + + +--------------------------------------------------------------------------------------------------- +-- Section +--------------------------------------------------------------------------------------------------- +-- Grammar and string formatting ------------------------------------------------------------------ +-- | Format a number with thousand separators +-- TODO: Allow non-integral numbers +thousands :: Int -> String +thousands = reverse . intercalate "," . chunks 3 . reverse . show + +-- | +-- TODO: Optional ellipsis argument +-- TODO: Better name (?) +-- let len = length s in take (min len $ n-3) s ++ take () "..." +abbreviate :: Int -> String -> String +abbreviate n s + | n < length s = let visible = n-3 in take visible s ++ "..." + | otherwise = s + + +-- | Divides a list into chunks of the given size +-- +-- assert chunks 5 "fivesknifelives" == ["fives", "knife", "lives"] -- TODO: Move this to a test section +-- +-- TODO: Implement with higher-order recursive function (cf. foldr, iterate, until) (?) +-- +chunks :: Int -> [a] -> [[a]] +chunks _ [] = [] +chunks n xs = let (chunk, rest) = splitAt n xs in chunk : chunks n rest +-- chunks n = unfoldr (\ xs -> if null xs then Nothing else splitAt n xs) + + +-- | +splitWith :: Eq a => ([a] -> ([a], [a])) -> [a] -> [[a]] +splitWith f = unfoldr cut + where cut [] = Nothing + cut xs = Just $ f xs + + +-- | +-- TODO: Rename (?) +split :: Eq a => a -> [a] -> [[a]] +split c = splitWith $ \ xs -> let (token, rest) = span (/=c) xs in (token, dropWhile (==c) rest) +-- split c s = filter (/=[c]) . groupBy ((==) `on` (==c)) $ s + + +-- | Same as Python's str.split (I think) (eg. split '|' "a||c" == ["a", "", "c"]) +-- TODO: Rename +-- TODO: Easier to implement with groupBy (?) +cuts :: Eq a => a -> [a] -> [[a]] +cuts c = splitWith $ \ xs -> let (token, rest) = span (/=c) xs in (token, drop 1 rest) + + +-- | +-- TODO: Accept a function (eg. (a -> a -> b)) +pairwise :: (a -> a -> b) -> [a] -> [b] +pairwise f xs = zipWith f xs $ drop 1 xs + + +-- Verb conjugation +{- where be 1 = "is" + be _ = "are" + suffix 1 = "" + suffix _ = "s" +-} + + +-- | Converts a positive integer to an English numeral. Numbers above twelve are converted to comma-separated strings +-- +-- TODO: +-- +numeral :: Int -> String +numeral n = case n of + 0 -> "zero" + 1 -> "one" + 2 -> "two" + 3 -> "three" + 4 -> "four" + 5 -> "five" + 6 -> "six" + 7 -> "seven" + 8 -> "eight" + 9 -> "nine" + 10 -> "ten" + 11 -> "eleven" + 12 -> "twelve" + _ -> thousands (n :: Int) + + +-- General utilities ------------------------------------------------------------------------------ +-- | Counts the number of elements that satisfy the predicate +count :: (a -> Bool) -> [a] -> Int +count p = length . filter p + + +--------------------------------------------------------------------------------------------------- +-- Tests +---------------------------------------------------------------------------------------------------
+ lib/Southpaw/WaveFront/Checks.hs view
@@ -0,0 +1,121 @@+-- +-- Southpaw.Wavefront.Checks +-- Executable containing checks and tests for the modules in this package +-- +-- Jonatan H Sundqvist +-- February 24 2015 +-- + +-- TODO | - Use QuickCheck (?) +-- - Full coverage +-- - Benchmarking + +-- SPEC | - +-- - + + + +module Southpaw.WaveFront.Checks where + + + +--------------------------------------------------------------------------------------------------- +-- We'll need these +--------------------------------------------------------------------------------------------------- +import Text.Printf (printf) +import Data.Either (lefts) +import Data.Char (toLower) +import System.IO (hFlush, stdout) + +import Control.Monad (forM_, when) + +import Southpaw.WaveFront.Parsers (loadOBJ, loadMTL, MTL, OBJ) + + +--------------------------------------------------------------------------------------------------- +-- Functions (IO) +--------------------------------------------------------------------------------------------------- +-- IO utilities ----------------------------------------------------------------------------------- +-- | +promptContinue :: String -> IO () +promptContinue prompt = do + putStr prompt + hFlush stdout + getChar + putChar '\n' + + + +-- | +-- +-- TODO: Refactor (cf. untilM) +-- TODO: Allow flexible feedback +-- TODO: Default return value for invalid replies (?) +-- TODO: Customisable validation (eg. for other languages than English) +-- +askYesNo :: String -> IO Bool +askYesNo q = do + putStr q + hFlush stdout + answer <- getLine + affirmed $ map toLower answer + where affirmed answer | answer `elem` ["yes", "y", "yeah"] = return True + | answer `elem` ["no", "n", "nah"] = return False + | otherwise = askYesNo "I don't understand. Answer 'yes' or 'no': " + -- return [(`elem` ["yes", "y", "yeah"]), (`elem` "no", "n", "nah")] + + +-- | +askPerformAction :: String -> IO () -> IO () +askPerformAction q action = do + affirmed <- askYesNo q + when affirmed action + + +-- | +showTokens :: Show a => [(Int, Either String a, String)] -> IO () +showTokens materials = mapM_ (uncurry $ printf "[%d] %s\n") [ (n, show token) | (n, Right token, comment) <- materials ] -- TODO: cf. line 65 + + + +--------------------------------------------------------------------------------------------------- +-- Entry point +--------------------------------------------------------------------------------------------------- +-- | +-- +-- TODO: Print culprit lines (✓) +-- +main :: IO () +main = do + putStrLn "This is where the checks should be." + + let path = "C:/Users/Jonatan/Desktop/Python/experiments/WaveFront/" + + forM_ ["queen", "cube"] $ \ fn -> do + printf "\nParsing OBJ file: %s.obj\n" fn + model <- loadOBJ $ printf (path ++ "data/%s.obj") fn + -- TODO: Utility for partioning a list based on several predicates ([a] -> [a -> Bool] -> [[a]]) + -- TODO: Utilities for displaying output and asking for input + -- TODO: Oh, the efficiency! + -- TODO: Less ugly naming convention for monadic functions which ignore the output (cf. mapM_, forM_, etc.) + let unparsed = lefts $ map second model + let comments = filter ('#' `elem`) unparsed + let blanks = filter null unparsed + let errors = length unparsed - (length comments + length blanks) + printf "Found %d invalid rows in OBJ file (%d comments, %d blanks, %d errors).\n" (length unparsed) (length comments) (length blanks) errors + when (length unparsed > 0) . askPerformAction "Would you like to see view them (yes/no)? " $ putStrLn "Ok, here they are:" >> mapM_ print unparsed + + promptContinue "Press any key to continue..." + + mapM (uncurry $ printf "[%d] %s\n") [ (n, show token) | (n, Right token, comment) <- model ] + -- TODO: Print culprit lines (✓) + + promptContinue "Press any key to continue..." + + printf "\nParsing MTL file: %s.mtl\n" fn + materials <- loadMTL $ printf "%sdata/%s.mtl" path fn + printf "Found %d invalid rows in MTL file (n comments, m blanks, o errors).\n" . length . lefts $ map second materials + showTokens materials + + promptContinue "Press any key to continue..." + where second (_, b, _) = b
+ lib/Southpaw/WaveFront/Foreign.hs view
@@ -0,0 +1,79 @@+-- +-- Wavefront - Foreign.hs +-- Foreign function interface +-- +-- Jonatan H Sundqvist +-- February 24 2015 +-- + +-- TODO | - Possible to get rid of newtypes +-- - Decide on an API + +-- SPEC | - +-- - + + +-- TODO: Why do same extensions start with 'X'? +{-# LANGUAGE ForeignFunctionInterface #-} + + + +module Southpaw.WaveFront.Foreign where + + + +--------------------------------------------------------------------------------------------------- +-- We'll need these +--------------------------------------------------------------------------------------------------- +import Foreign.Storable +import qualified Foreign.C as C +import qualified Southpaw.WaveFront.Parsers as Parsers + +import System.IO.Unsafe (unsafePerformIO) + + + +--------------------------------------------------------------------------------------------------- +-- Types +--------------------------------------------------------------------------------------------------- +-- | +newtype COBJ = COBJ Parsers.OBJ + + +-- | +newtype CMTL = CMTL Parsers.MTL + + +-- | We +instance Storable COBJ where + sizeOf = const 0 + alignment = const 0 + + +-- | We +instance Storable CMTL where + sizeOf = const 0 + alignment = const 0 + + + +--------------------------------------------------------------------------------------------------- +-- Functions +--------------------------------------------------------------------------------------------------- +-- | +-- I feel dirty... +parseOBJ :: C.CString -> COBJ +parseOBJ = COBJ . Parsers.parseOBJ . unsafePerformIO . C.peekCString + +-- | +parseMTL :: C.CString -> CMTL +parseMTL = CMTL . Parsers.parseMTL . unsafePerformIO . C.peekCString + + + +--------------------------------------------------------------------------------------------------- +-- Pure foreign function interface +--------------------------------------------------------------------------------------------------- +-- I feel the urge to make a joke about 'Unacceptable argument in foreign declaration' +-- foreign export ccall parseOBJ :: C.CString -> COBJ +-- foreign export ccall parseMTL :: C.CString -> CMTL
+ lib/Southpaw/WaveFront/Parsers.hs view
@@ -0,0 +1,438 @@+-- | +-- Module : Southpaw.WaveFront.Parsers +-- Description : descr +-- Copyright : (c) Jonatan H Sundqvist, February 8 2015 +-- License : MIT +-- Maintainer : Jonatan H Sundqvist +-- Stability : experimental|stable +-- Portability : POSIX (not sure) +-- +-- Created February 8 2015-- Wavefront - Parsers.hs +-- Migrated to separate project on February 21 2015 + +-- TODO | - Appropriate container types (eg. bytestring, vector) +-- - Grammar specification +-- - Incremental parsing (?) +-- - Improve naming scheme +-- +-- - Separate MTL and OBJ parsers (?) (...) +-- - Separate parsing, processing, logging, IO and testing (...) +-- -- Proper path handling (eg. include root in MTLTable or not) +-- +-- - Additional attributes (lighting, splines, etc.) +-- - FFI (...) +-- - Debugging information (line number, missing file, missing values, etc.) (...) +-- - Proper Haddock coverage, including headers (...) +-- - Model type (...) +-- - Caching (?) +-- - Performance, profiling, optimisations +-- -- Strict or lazy (eg. with Data.Map) (?) +-- +-- - PrintfArg instances for the types defined in this module +-- - Reconciling Cabal and hierarchical modules +-- - Dealing with paths in lib statements (requires knowledge of working directories) +-- - Move comments and specification to separate files (eg. README) +-- - Inline comments (for internals, implementation) +-- +-- - Full OBJ spec compliance +-- -- Do the usemtl and libmtl statements affect vertices or faces (?) +-- +-- - Parser bugs +-- -- Negative coordinates enclosed in parentheses +-- +-- - Decide on a public interface (exports) (API) +-- -- Model will be the main API type +-- -- Processing utils (eg. iterating over model faces; withModelFaces :: ((Material, [(Vertex, Maybe Normalcoords, Maybe Texcoords)]) -> b) -> Model -> [b]) +-- -- Export functions for working with the output data (eg. unzipIndices :: [(Int, Int, Int)] -> ([Int], [Int], [Int])) +-- -- Export certain utilities (eg. second, perhaps in another module) (?) + +-- SPEC | - +-- - + + + +--------------------------------------------------------------------------------------------------- +-- GHC Extensions +--------------------------------------------------------------------------------------------------- +{-# LANGUAGE UnicodeSyntax #-} +{-# LANGUAGE TupleSections #-} + + + +--------------------------------------------------------------------------------------------------- +-- Section +--------------------------------------------------------------------------------------------------- +module Southpaw.WaveFront.Parsers (parseOBJ, parseMTL, + loadOBJ, loadMTL, loadModel, + facesOf, materialsOf, + MTL(), OBJ(), Model(..), Face(..), Material(..), OBJToken(..), MTLToken(..), + createModel) where + + + +--------------------------------------------------------------------------------------------------- +-- We'll need these +--------------------------------------------------------------------------------------------------- +import Data.List (groupBy) +import Data.Maybe (listToMaybe) +import Data.Either (rights, isLeft) + +import Text.Read (readMaybe, readEither) + +import Southpaw.Utilities.Utilities (pairwise, cuts) +import Southpaw.WaveFront.Utilities + +import qualified Data.Map as Map + +import System.FilePath (splitFileName, (</>)) +import Control.Monad (forM_) + +-- import Control.Concurrent (threadDelay) +import Text.Printf (printf) +import System.IO (hFlush, stdout) + + + +--------------------------------------------------------------------------------------------------- +-- Types +--------------------------------------------------------------------------------------------------- +-- OBJ parser types ------------------------------------------------------------------------------- +-- | Represents a single (valid) OBJ token +-- +-- TODO: Polymorphic numerical types (?) +-- TODO: Add context, metadata (eg. line numbers, filename) (?) +-- TODO: Naming scheme (added OBJ prefix to prevent name clashes; cf. Face type) +-- TODO: Comment token (preserve comments in parser output or remove them) (?) +data OBJToken = OBJVertex Float Float Float | + OBJNormal Float Float Float | + OBJTexture Float Float | + OBJFace [(Int, Maybe Int, Maybe Int)] | -- TODO: Associate material with each face, handle absent indices + + UseMTL String | -- + LibMTL String | -- TODO: Use actual MTL type + + Group [String] | -- TODO: Do grouped faces have to be consecutive? + Object [String] -- TODO: What is the difference between group and object? + deriving (Eq, Show) -- TODO: Derive Read (?) + + +-- | +-- TODO: Use error type instead of String, allowing us to distinguish invalid data +-- from eg. comments and blank lines (?) +type OBJRow = (Either String OBJToken, String) + + +-- | Output type of the OBJ parser. Currently a list of line number and token (or error string) pairs +-- +-- TODO: Rename (?) +-- TODO: Use Integral for line number (?) +-- +type OBJ = [(Int, Either String OBJToken, String)] + + +-- MTL parser types ------------------------------------------------------------------------------- +-- | Represents a single (valid) MTL token +-- +-- TODO: Is the alpha channel optional, ignored, disallowed? +-- TODO: Include support for ('Ns', 'Ni', 'd', 'Tr', 'illum') +-- +data MTLToken = Ambient Float Float Float (Maybe Float) | -- Ka + Diffuse Float Float Float (Maybe Float) | -- Kd + Specular Float Float Float (Maybe Float) | -- Ks + + MapDiffuse String | -- map_Kd + NewMaterial String -- newmtl + deriving (Eq, Show) + + +-- | Output type of the single-row MTL parser. +type MTLRow = (Either String MTLToken, String) + + +-- | Output type of the MTL parser. Currently a list of line number and token (or error string) pairs +-- +-- TODO: Add type for processed MTL (eg. a map between names and materials) +-- +type MTL = [(Int, Either String MTLToken, String)] -- (line number, MTL token, comment) + + +-- | +type MTLTable = Map.Map String (Map.Map String Material) + + +-- General types ---------------------------------------------------------------------------------- +type Vector num = (num, num, num) -- Queen Vectoria +type Point num = (num, num) -- Haskell is no longer Point-free + + +-- API types -------------------------------------------------------------------------------------- +-- | +-- TODO: Validation (eg. length ivertices == length == ivertices == length itextures if length isn't 0) +-- TOOD: Pack indices in a tuple (eg. indices :: [(Int, Int, Int)]) (?) +-- TOOD: Use (String, String) for the names of the mtl file and material instead of Material (?) +data Face = Face { indices :: [(Int, Maybe Int, Maybe Int)], material :: Material } deriving (Show) + + +-- | +type Colour = (Float, Float, Float, Float) + + +-- | +-- TODO: Do all materials have an ambient, a diffuse and a specular colour (?) +-- TODO: Support more attributes (entire spec) (?) +-- TODO: Lenses (?) +data Material = Material { ambient :: Colour, diffuse :: Colour, specular :: Colour, texture :: Maybe String } deriving (Show) + + +-- | Abstract representation of an OBJ model with associated MTL definitions. +-- +-- +-- TODO: Rename (?) +-- TODO: Include metadata, comments, rejected data (?) +-- TODO: Separate type for processed OBJTokens (ie. token + context) +-- TODO: Perform index lookups (?) +-- TODO: Reconsider the types (especially of the materials) +-- +data Model = Model { vertices :: [Vector Float], + normals :: [Vector Float], + textures :: [Point Float], + faces :: [Face], + materials :: MTLTable, -- TODO: Type synonym (?) + groups :: Map.Map [String] (Int, Int), -- TODO: Type synonym + objects :: Map.Map [String] (Int, Int) -- TODO: Type synonym + } deriving (Show) + + + +--------------------------------------------------------------------------------------------------- +-- Functions (pure) +--------------------------------------------------------------------------------------------------- +-- OBJ parsing ------------------------------------------------------------------------------------ +-- | This function creates an OBJToken or error for each line in the input data +-- +-- TODO: Use appropriate container type (cf. TODO section) +-- TODO: Extract filter predicate (isComment, isEmpty) +-- TODO: Is it even necessary to strip whitespace? +-- TODO: Function for composing predicates (?) +-- TODO: Should this function separate the various fields (eg. [(Vertices, Faces, Materials, Groups)] instead of [Maybe OBJToken]) +-- +parseOBJ :: String -> OBJ +parseOBJ = enumerate . map parseOBJRow . lines -- . rows + + +-- | Generates a token given a single valid OBJ row, or an error value if the input is malformed. +-- +-- TODO: Correctness (total function, no runtime exceptions) +-- TODO: Rename 'which' (?) +-- TODO: Handle invalid rows (how to deal with mangled definitions w.r.t indices?) +-- TODO: Extract value parsing logic (eg. pattern matching, converting, handle errors) + +-- TODO: Named errors (typed?) rather than Nothing (cf. Either) (?) +-- Type for unsupported but valid (according to spec) attributes (?) +-- Type for specific attribute that failed to parse (eg. "f 1/2 0/p 1.5/x") +-- +-- TODO: Additional values, currently unsupported attributes (ignore?) (pattern match against the entire line, eg. ["vn", x, y, z]) +-- TODO: Dealing with MTL definitions (pass in names, MTL value, return list of MTL dependencies) +-- TODO: Take 1-based indexing into account straight away (?) +-- TODO: Deal with absent texture and normal indices +-- TODO: Strip trailing comments (✓) +-- TODO: Don't ignore leftover values (errors?) (...) +-- +parseOBJRow :: String -> OBJRow -- Maybe OBJToken +parseOBJRow ln = parseTokenWith ln $ \ (attr:values) -> case attr:values of + ("f":_:_:_:_) -> either (Left . const ln) (Right . OBJFace) . sequence . map (ivertex . cuts '/') $ values -- Face + ["v", sx, sy, sz] -> vector (\ [x, y, z] -> OBJVertex x y z) [sx, sy, sz] -- Vertex + ["vn", sx, sy, sz] -> vector (\ [x, y, z] -> OBJNormal x y z) [sx, sy, sz] -- Normal + ["vt", sx, sy] -> vector (\ [x, y] -> OBJTexture x y) [sx, sy] -- Texture + ("g":_) -> Right . Group $ values -- Group + ("o":_) -> Right . Object $ values -- Object + ("s":_) -> Left ln -- Smooth shading + ["mtllib", lib] -> Right . LibMTL $ lib -- + ["usemtl", mtl] -> Right . UseMTL $ mtl -- + _ -> Left ln -- TODO More informative errors + where ivertex [svi, sti, sni] = readEither svi >>= \ vi -> Right $ (vi, readMaybe sti, readMaybe sni) -- TODO: Refactor, simplify + ivertex is = Left $ "Face vertex with too many indices: " ++ show is -- This value will simply be discarded by the "f" case + + +-- MTL parsing ------------------------------------------------------------------------------------ +-- | Produces a list of MTL tokens, with associated line numbers and comments +parseMTL :: String -> MTL +parseMTL = enumerate . map parseMTLRow . lines + + +-- | Parses a single MTL row. +-- +-- TOOD: Simplify 'withChannels' +-- TOOD: Process the MTL tokens (✗) +-- TODO: cf. parseOBJRow +-- +parseMTLRow :: String -> MTLRow +parseMTLRow ln = parseTokenWith ln $ \ (which:values) -> case which:values of + ("Ka":sr:sg:sb:rest) -> withChannels Ambient sr sg sb rest -- Ka + ("Kd":sr:sg:sb:rest) -> withChannels Diffuse sr sg sb rest -- Kd + ("Ks":sr:sg:sb:rest) -> withChannels Specular sr sg sb rest -- Ks + ["map_Kd", name] -> Right $ MapDiffuse name -- map_Kd + ["newmtl", name] -> Right $ NewMaterial name -- newmtl + _ -> Left ln -- + where withChannels f sr sg sb [] = vector (\[r, g, b] -> f r g b Nothing) [sr, sg, sb] -- TODO: Refactor, simplify + withChannels f sr sg sb [sa] = vector (\[r, g, b] -> f r g b $ readMaybe sa) [sr, sg, sb] -- TODO: Refactor, simplify + withChannels _ _ _ _ _ = Left "Wrong number of colour channels" + + +-- Parser output churners (OBJ) ------------------------------------------------------------------- +-- | Creates a mapping between group names and the corresponding bounds ([lower, upper)). Invalid +-- tokens are simply discarded by this function. +-- +-- TODO: Figure out how to deal with multiple group names (eg. "g mesh1 nose head") +groupsOf :: [OBJToken] -> Map.Map [String] (Int, Int) +groupsOf = buildIndexMapWith . filter notObject + where notObject (Object _) = False + notObject _ = True + + +-- | +objectsOf :: [OBJToken] -> Map.Map [String] (Int, Int) +objectsOf = buildIndexMapWith . filter notGroup + where notGroup (Group _) = False + notGroup _ = True + + +-- | Creates a mapping between names (of groups or objects) to face indices +-- +-- TODO: Refactor, simplify +-- +buildIndexMapWith :: [OBJToken] -> Map.Map [String] (Int, Int) +buildIndexMapWith tokens = Map.fromList . pairwise zipIndices . reverse . addLastIndex $ foldl update (0, []) $ tokens + where addLastIndex (nfaces, groups') = ([], nfaces):groups' + zipIndices (names, low) (_, upp) = (names, (low, upp)) + update (nfaces, groups') token = case token of + Group names -> (nfaces, (names, nfaces):groups') + Object names -> (nfaces, (names, nfaces):groups') + OBJFace _ -> (nfaces+1, groups') + _ -> (nfaces, groups') + + +-- | Filters out faces from a stream of OBJTokens and attaches the currently selected material, +-- as defined by the most recent LibMTL and UseMTL tokens. +-- +-- TODO: Don't use foldl (?) +-- TODO: Deal with errors (eg. missing materials) +-- TODO: Improve naming scheme (lots of primes) +-- TODO: Default material, take 'error-handling' function (?) +-- +facesOf :: [OBJToken] -> MTLTable -> [Either String Face] +facesOf tokens table = reverse . third . foldl update ("", "", []) $ tokens + where retrieve lib mat = Map.lookup lib table >>= Map.lookup mat + createFace lib mat ind = case retrieve lib mat of + Nothing -> Left $ "No such material: " ++ lib ++ "." ++ mat + Just m -> Right $ Face { indices=ind, material=m } + update (lib', material', faces') token = case token of + OBJFace ind -> (lib', material', createFace lib' material' ind : faces') + LibMTL lib -> (lib, material', faces') + UseMTL mat -> (lib', mat, faces') + _ -> (lib', material', faces') + + +-- Parser output churners (MTL) ------------------------------------------------------------------- +-- | Constructs a map between names and materials. Partially or wholly undefined materials +-- are mapped to a string detailing the error (eg. Left "missing specular"). +-- +-- TODO: Debug information (eg. attributes without an associated material) +-- TODO: Pass in error function (would allow for more flexible error handling) (?) +-- TODO: Filter out parser failures (?) +-- TOOD: Deal with duplicated attributes (probably won't crop up in any real situations) +materialsOf :: [MTLToken] -> Map.Map String (Either String Material) +materialsOf tokens = Map.fromList . rights $ map createMaterial groups + where groups = groupBy (((not . isnew) .) . flip const) tokens -- TODO: Refactor this atrocity + isnew (NewMaterial _) = True -- TODO: Rename isnew + isnew _ = False + createMaterial (NewMaterial name:attrs) = Right $ (name, fromAttributes attrs) + createMaterial attrs = Left $ "Free-floating attributes: " ++ show attrs + fromAttributes attrs + | any null colours = Left $ "Missing colour(s)" -- TODO: More elaborate message (eg. which colour) + | otherwise = Right $ Material { ambient=head amb, diffuse=head diff, specular=head spec, texture=listToMaybe [ name | MapDiffuse name <- attrs ] } + where colours@[diff, spec, amb] = [[ (r, g, b, maybe 1.0 id a) | Diffuse r g b a <- attrs ], + [ (r, g, b, maybe 1.0 id a) | Specular r g b a <- attrs ], + [ (r, g, b, maybe 1.0 id a) | Ambient r g b a <- attrs ]] + + +-- | +-- TODO: Debug information (eg. how many invalid materials were filtered out) +-- TODO: Refactor, simplify +createMTLTable :: [(String, [MTLToken])] -> MTLTable +createMTLTable mtls = Map.fromList . map (\ (name, tokens) -> (name, Map.mapMaybe prune . materialsOf $ tokens)) $ mtls + where prune (Right mat) = Just mat + prune (Left _) = Nothing + + +-- API functions ---------------------------------------------------------------------------------- +-- | +-- TODO: Use map for materials (?) +-- TODO: How to retrieve MTL data +-- TODO: How to deal with errors, including no-parse, index errors, etc. +-- TODO: Performance, how are 'copies' of coordinates handled (?) +-- TODO: Performance, one pass (with a fold perhaps) +-- TODO: Use a more efficient data structure (especially w.r.t indexing; cf. Vector) +-- TODO: Consider preserving the indices (rather than generating a list of duplicated vertices). +-- This would preserve space (in cases where vertices are often re-used), as well as being +-- very compatible with index buffers on graphics cards. +-- +-- TODO: Keep map of materials and list of textures in final output (inside model or as items in a tuple) (?) +-- +-- I never knew pattern matching in list comprehensions could be used to filter by constructor +-- let rows = parseOBJ data in ([ v | @v(Vertex {}) <- rows], [ v | @v(Vertex {}) <- rows]) +createModel :: OBJ -> MTLTable -> Model +createModel tokens materials = let modeldata = rights $ map second tokens -- TODO: Vat do vee du viz ze dissidents, kommandant? + in Model { vertices = [ (x, y, z) | OBJVertex x y z <- modeldata ], + normals = [ (x, y, z) | OBJNormal x y z <- modeldata ], + textures = [ (x, y) | OBJTexture x y <- modeldata ], + faces = rights $ facesOf modeldata materials, + groups = groupsOf modeldata, + objects = objectsOf modeldata, + materials = materials } + + +--------------------------------------------------------------------------------------------------- +-- Functions (IO) +--------------------------------------------------------------------------------------------------- +-- Loading data ----------------------------------------------------------------------------------- +-- | +-- +-- TODO: Use bytestrings (?) +-- +loadOBJ :: String -> IO OBJ +loadOBJ fn = do + rawOBJ <- readFile fn -- + return $ parseOBJ rawOBJ -- + + +-- | +-- +-- TODO: Use bytestrings (?) +-- TODO: Merge OBJ and MTL parsers (and plug in format-specific code as needed) (?) +-- +loadMTL :: String -> IO MTL +loadMTL fn = do + rawMTL <- readFile fn -- Unparsed MTL data (text) + return $ parseMTL rawMTL -- + + +-- | +-- TODO: Better names (than 'mtls' and 'fns') (?) +-- TODO: Refactor, simplify +-- TODO: Improve path handling (cf. '</>') +loadMaterials :: [String] -> IO MTLTable +loadMaterials fns = do + mtls <- mapM loadMTL fns -- + return . createMTLTable . zip (map (snd . splitFileName) fns) . map tokensOf $ mtls -- + where tokensOf = rights . map second + + +-- | +-- Loads an OBJ model from file, including associated materials +loadModel :: String -> IO Model +loadModel fn = do + obj <- loadOBJ fn + materials <- loadMaterials [ (fst $ splitFileName fn) </> name | LibMTL name <- rights $ map second obj ] + return $ createModel obj materials + where loadWithName name = loadMTL name >>= return . (name,)
+ lib/Southpaw/WaveFront/Utilities.hs view
@@ -0,0 +1,101 @@+-- | +-- Module : Southpaw.WaveFront.Utilities +-- Description : Parsing utilities +-- Copyright : (c) Jonatan H Sundqvist, 2015 +-- License : MIT +-- Maintainer : Jonatan H Sundqvist +-- Stability : experimental|stable +-- Portability : POSIX (not sure) +-- + +-- Created July 15 2015 + +-- TODO | - +-- - + +-- SPEC | - +-- - + + + +module Southpaw.WaveFront.Utilities where + + + +--------------------------------------------------------------------------------------------------- +-- We'll need these +--------------------------------------------------------------------------------------------------- +import Data.List (isPrefixOf) +import Data.Char (isSpace) +import Text.Read (readEither) + + +--------------------------------------------------------------------------------------------------- +-- Functions +--------------------------------------------------------------------------------------------------- +-- Parsing utilities ------------------------------------------------------------------------------ +-- | +parseTokenWith :: String -> ([String] -> Either String a) -> (Either String a, String) +parseTokenWith ln parse + | null ln || isComment ln = withoutComment ln $ Left + | otherwise = withoutComment ln $ parse . words + + +-- | Predicate for determining if a String is a comment. Comments are preceded by a '#' and any +-- number of whitespace characters (not including linebreaks). Support for comments at the end +-- of a line has yet to be added. +-- +-- TODO: Drop comments at the end of a line (?) +-- TODO: Add stripComment (or extractComment) which consumes a line up until the first '#'. +-- This would allow for tokens and comments to appear on the same line. +isComment :: String -> Bool +isComment = isPrefixOf "#" . dropWhile isSpace + + +-- | Strips a trailing comment from an MTL or OBJ line. +dropComment :: String -> String +dropComment = takeWhile (/= '#') + + +-- | +takeComment :: String -> String +takeComment = dropWhile (/= '#') + + +-- | +withoutComment :: String -> (String -> a) -> (a, String) +withoutComment row parse = let (tokens, comment) = span (/= '#') row in (parse tokens, comment) + + +-- | +enumerate :: [(token, comment)] -> [(Int, token, comment)] +enumerate = zipWith prepend [1..] + where prepend n (token, comment) = (n, token, comment) + + +-- | Splits a string into rows and filters out unimportant elements (empty lines and comments) +-- NOTE: This function is probably obsolete due to comments being included by the parsers +-- TODO: Higher order function for composing predicates +rows :: String -> [String] +rows = filter (not . satisfiesAny [null, isComment]) . lines + where satisfiesAny predicates x = any ($ x) predicates + + +-- | +-- TODO: Use readMaybe (?) +-- TODO: Variadic 'unpacking' (or is that sinful?) +-- TODO: More informative error message (?) +-- TODO: Rename (?) +-- TODO: Generic function for mapping and sequencing readEither (cf. "vt" case in parseOBJRow) (?) +vector :: Read r => ([r] -> b) -> [String] -> Either String b +vector f coords = sequence (map readEither coords) >>= Right . f +-- vector _ _ = Left $ "Wrong number of coordinates for vector" + + +-- | +second :: (a, b, c) -> b +second (_, b, _) = b + +-- | +third :: (a, b, c) -> c +third (_, _, c) = c