Browse files

initial commit

  • Loading branch information...
0 parents commit 1bc2246aa77af7433ae150d61b4942298f7dd004 @kfish committed Nov 22, 2011
Showing with 194 additions and 0 deletions.
  1. +95 −0 Graphics/TextureSynthesis.hs
  2. +30 −0 LICENSE
  3. +2 −0 Setup.hs
  4. +57 −0 texture-synthesis.cabal
  5. BIN tools/.texture-synthesis.hs.swp
  6. +10 −0 tools/texture-synthesis.hs
95 Graphics/TextureSynthesis.hs
@@ -0,0 +1,95 @@
+{-# LANGUAGE RecordWildCards #-}
+{-# OPTIONS -Wall #-}
+
+module Graphics.TextureSynthesis (
+ Texture(..)
+ , textureEmpty
+ , mkTexture
+ , flattenTexture
+) where
+
+import Data.Map (Map)
+import qualified Data.Map as Map
+
+-- | Point on the 2D plane
+data I2 = I2 !Int !Int
+ deriving (Eq, Ord, Show)
+
+----------------------------------------------------------------------
+
+data QuadTree a = QuadTree {
+ treeLevel :: Int
+ , c :: a
+ , n, e, w, s :: a
+ , nw, ne, sw, se :: QuadTree a
+ } | QuadNil
+ deriving (Show)
+
+data Texture a = Texture {
+ topLeft, topRight, botLeft, botRight :: a
+ , tree :: QuadTree a
+ }
+ deriving (Show)
+
+textureEmpty :: Texture Float
+textureEmpty = Texture 0 0 0 0 QuadNil
+
+mkTexture :: Int -> Texture Float
+mkTexture lim = Texture 0 0 0 0 (mkQuad lim 0 0 0 0 0)
+
+mkQuad :: (Fractional a) => Int -> Int -> a -> a -> a -> a -> QuadTree a
+mkQuad lim lvl tL tR bL bR
+ | lvl >= lim = QuadNil
+ | otherwise = QuadTree
+ { treeLevel = lvl'
+ , c = c'
+ , n = n'
+ , e = e'
+ , w = w'
+ , s = s'
+ , nw = mkQuad lim lvl' tL n' w' c'
+ , ne = mkQuad lim lvl' n' tR c' e'
+ , sw = mkQuad lim lvl' w' c' bL s'
+ , se = mkQuad lim lvl' c' e' s' bR
+ }
+ where
+ lvl' = lvl+1
+ c' = (tL + tR + bL + bR) / 4
+ n' = (tL + tR) / 2
+ e' = (tR + bR) /2
+ w' = (tL + bL) /2
+ s' = (bL + bR) /2
+
+flattenTexture :: Int -> Texture a -> [(I2, a)]
+flattenTexture n Texture{..} =
+ [ (I2 0 0, topLeft)
+ , (I2 l 0, topRight)
+ , (I2 0 l, botLeft)
+ , (I2 l l, botRight)
+ ] ++ flattenQuad n (I2 0 0) (I2 l l) tree
+ where
+ l = 2^n
+
+flattenQuad :: Int -> I2 -> I2 -> QuadTree a -> [(I2, a)]
+flattenQuad lim x1y1 x2y2 q = Map.assocs (quadToMap lim x1y1 x2y2 q)
+
+quadToMap :: Int -> I2 -> I2 -> QuadTree a -> Map I2 a
+quadToMap _ _ _ QuadNil = Map.empty
+quadToMap lim (I2 x1 y1) (I2 x2 y2) QuadTree{..}
+ | treeLevel >= lim = Map.empty
+ | otherwise = result
+ where
+ result = Map.unions [cnews, nw', ne', sw', se']
+ cnews = Map.fromList [ (I2 xH yH, c)
+ , (I2 xH y1, n)
+ , (I2 x2 yH, e)
+ , (I2 x1 yH, w)
+ , (I2 xH y2, s)
+ ]
+ nw' = quadToMap lim (I2 x1 y1) (I2 xH yH) nw
+ ne' = quadToMap lim (I2 xH y1) (I2 x2 yH) ne
+ sw' = quadToMap lim (I2 x1 yH) (I2 xH y2) sw
+ se' = quadToMap lim (I2 xH yH) (I2 x2 y2) se
+
+ xH = x1 + (x2-x1) `div` 2
+ yH = y1 + (y2-y1) `div` 2
30 LICENSE
@@ -0,0 +1,30 @@
+Copyright (c)2011, Conrad Parker
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of Conrad Parker nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
2 Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
57 texture-synthesis.cabal
@@ -0,0 +1,57 @@
+Name: texture-synthesis
+
+-- The package version. See the Haskell package versioning policy
+-- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for
+-- standards guiding when and how versions should be incremented.
+Version: 0.1.0.0
+
+Synopsis: Texture synthesis
+
+-- Description:
+
+License: BSD3
+License-file: LICENSE
+Author: Conrad Parker
+Maintainer: conrad@metadecks.org
+Stability: Experimental
+Category: Graphics
+
+Cabal-version: >=1.8
+Build-type: Simple
+
+flag splitBase
+ description: Use the split-up base package.
+
+Library
+ if flag(splitBase)
+ build-depends:
+ base >= 3 && < 6
+ else
+ build-depends:
+ base < 3
+
+ Exposed-modules:
+ Graphics.TextureSynthesis
+
+ Build-depends:
+ containers >= 0.2 && < 0.5
+
+ -- Modules not exported by this package.
+ -- Other-modules:
+
+ -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source.
+ -- Build-tools:
+
+Executable texture-synthesis
+ Main-is: texture-synthesis.hs
+ Hs-Source-Dirs: ., tools
+
+ if flag(splitBase)
+ build-depends:
+ base >= 3 && < 6
+ else
+ build-depends:
+ base < 3
+
+ Build-Depends:
+ containers >= 0.2 && < 0.5
BIN tools/.texture-synthesis.hs.swp
Binary file not shown.
10 tools/texture-synthesis.hs
@@ -0,0 +1,10 @@
+{-# OPTIONS -Wall #-}
+
+module Main where
+
+import Graphics.TextureSynthesis
+
+main :: IO ()
+main = do
+ let ts = mkTexture 8
+ print ts

0 comments on commit 1bc2246

Please sign in to comment.