deepzoom (empty) → 0.1

raw patch · 4 files changed

+165/−0 lines, 4 filesdep +basedep +directorydep +filepathsetup-changed

Dependencies added: base, directory, filepath, hsmagick

Files

Graphics/Transform/DeepZoom/Slice.hs +114/−0
LICENSE +31/−0
Setup.hs +2/−0
deepzoom.cabal +18/−0

+ Graphics/Transform/DeepZoom/Slice.hs view

@@ -0,0 +1,114 @@+module Graphics.Transform.DeepZoom.Slice+( sliceImage ) where++import Graphics.Transform.Magick.Images+import qualified Graphics.Transform.Magick.Types as Magick+import Foreign.Storable+import Foreign.ForeignPtr (withForeignPtr)+import Data.Int+import Data.Word+import Data.List+import Data.Foldable (foldlM)+import System.FilePath+import System.Directory++data Tile = Tile { col :: Int, row :: Int, rect :: Magick.Rectangle } deriving (Show)++-- | Borrowed from snap-photogallery+data Dimension = Dimension { width :: Int, height :: Int } deriving (Show)++makeDimension :: Integral a => a -> a -> Dimension+makeDimension width height = Dimension (fromIntegral width) (fromIntegral height)++-- | Returns the maximum size between the width and the edeg+getMax :: Dimension -> Int+getMax (Dimension x y) = max x y++reduce :: Dimension -> Dimension+reduce (Dimension width height) = +  makeDimension (halfOrOne width) (halfOrOne height)+  where halfOrOne x = max 1 (ceiling ((fromIntegral x) / 2))++maxLevel :: Integral b => Dimension -> b+maxLevel dimension = ceiling (logBase 2 (fromIntegral (getMax dimension)))++getDimension :: Magick.HImage -> IO Dimension+getDimension himg =+  withForeignPtr (Magick.getImage himg) $ \p -> do+    img <- peek p+    return $ Dimension (fromIntegral (Magick.columns img)) (fromIntegral (Magick.rows img))++scaleImageToDimension :: Dimension -> Magick.HImage -> Magick.HImage+scaleImageToDimension(Dimension width height) image = +  scaleImage (fromIntegral width) (fromIntegral height) image++tileOffset :: Integral a => a -> a -> a -> a+tileOffset tileSize overlap position+  | position == 0 = 0+  | otherwise     = (position * tileSize) - overlap++tileDimension :: Integral a => a -> a -> a -> a+tileDimension tileSize overlap position+  | position ==  0 = tileSize + overlap+  | otherwise      = tileSize + 2 * overlap++makeRectangle :: Integral a => a -> a -> a -> a -> Magick.Rectangle+makeRectangle width height x y = +  Magick.Rectangle (fromIntegral width) (fromIntegral height)+                   (fromIntegral x) (fromIntegral y)++calcTiles :: Int -> Int -> Dimension -> [Tile]+calcTiles tileSize overlap (Dimension width height) = +  [(Tile x y (makeRectangle (dimensionFor x) (dimensionFor y) +                            (offsetFor x) (offsetFor y))) | x <- [0..cols], y <- [0..rows]]+    where offsetFor = tileOffset tileSize overlap+          dimensionFor = fromIntegral . (tileDimension tileSize overlap)+          rows = fromIntegral $ div height tileSize+          cols = fromIntegral $ div width tileSize++tileFileName :: Tile -> String+tileFileName tile = (intercalate "_" $ map show [(col tile), (row tile)]) ++ ".jpg"++tilePathName :: String -> Int -> Tile -> String+tilePathName baseDir level tile = joinPath [baseDir, show level, tileFileName tile]++sliceTile :: String -> Int -> Magick.HImage -> Tile -> IO ()+sliceTile baseDir level image tile = +  writeImage (tilePathName baseDir level tile) (cropImage (rect tile) image)++sliceReduce :: Int -> Int -> String -> Magick.HImage -> Int -> IO Magick.HImage+sliceReduce tileSize overlap baseDir image level = do+  imageDimensions <- getDimension image+  mapM_ (sliceTile baseDir level image) (calcTiles tileSize overlap imageDimensions)+  return $ scaleImageToDimension (reduce imageDimensions) image++appendPath :: FilePath -> FilePath -> FilePath+appendPath path newPart = joinPath (path : newPart : [])++deepZoomPath :: FilePath -> FilePath+deepZoomPath imagePath = joinPath [takeDirectory imagePath, takeBaseName imagePath ++ "_files"]++deepZoomXML :: Int -> Int -> Dimension -> String+deepZoomXML tileSize overlap (Dimension width height) = +  "<?xml version='1.0' encoding='UTF-8'?>" +++  "<Image TileSize='" ++ (show tileSize) ++ "' Overlap='" ++ (show overlap)  ++ "' " ++ +  "Format='jpg' xmlns='http://schemas.microsoft.com/deepzoom/2008'>" ++ +  "<Size Width='" ++ (show width) ++ "' Height='" ++ (show height) ++ "'/></Image>"++writeDeepZoomXML :: Int -> Int -> Dimension -> FilePath -> IO ()+writeDeepZoomXML tileSize overlap dimensions imagePath = +  writeFile (joinPath [takeDirectory imagePath, takeBaseName imagePath ++ ".xml"]) +    (deepZoomXML tileSize overlap dimensions)++sliceImage :: FilePath -> IO ()+sliceImage imagePath = do+  initializeMagick+  image <- readImage imagePath+  imageDimensions <- getDimension image+  let levels = maxLevel imageDimensions+  let baseDir = deepZoomPath imagePath++  mapM_ ((createDirectoryIfMissing True) . (appendPath baseDir) . show) [0..levels]+  foldlM (sliceReduce 256 4 baseDir) image [levels, (levels-1)..0]+  writeDeepZoomXML 256 4 imageDimensions imagePath+

+ LICENSE view

@@ -0,0 +1,31 @@+Copyright (c) Matthew Panetta <matthew@panetta.id.au> 2012++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.++2. 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.++3. Neither the name of the author nor the names of his contributors+   may be used to endorse or promote products derived from this software+   without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``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 AUTHORS 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.+

+ Setup.hs view

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

+ deepzoom.cabal view

@@ -0,0 +1,18 @@+Name:                deepzoom+Version:             0.1+Description:         A DeepZoom image slicer+Synopsis:            A DeepZoom image slicer.  Only known to work on 32bit Linux+Category:            Graphics+License:             BSD3+License-file:        LICENSE+copyright:           (c) Matthew Panetta, 2012 +stability:           alpha+Author:              Matthew Panetta+Maintainer:          matthew@panetta.id.au+Build-Type:          Simple+Cabal-Version:       >=1.2++Library+  Build-Depends:     base >= 3 && < 5, hsmagick, filepath, directory+  Exposed-modules:   Graphics.Transform.DeepZoom.Slice+  ghc-options:       -Wall