CropImage.hs

{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE AllowAmbiguousTypes #-}

module CropImage
    ( 
    cropImage
    ) where

import Utils
import Control.Monad ( void )
import Control.Monad.Except
import Data.Word
import Data.Proxy
import qualified OpenCV as CV
import Linear.V2
import OpenCV.TypeLevel
import qualified OpenCV.Internal.Core.Types.Mat as M
import qualified OpenCV.Core.Types.Size as S
import qualified OpenCV.ImgProc.GeometricImgTransform as GIT
import GHC.Int (Int32)

 
medianBlurImage :: (depth `In` '[Word8, Word16, Float], channels `In` '[1, 3, 4]) => (M.Mat shape ('S channels) ('S depth)) -> CV.CvExcept (M.Mat shape ('S channels) ('S depth)) 
medianBlurImage image = CV.medianBlur image 13 --Trying to do it "pure", but telling the Type.

cropImage :: (depth `In` '[Word8, Word16, Float], channels `In` '[1, 3, 4]) => M.Mat ('S '[height0, width0]) ('S channels) ('S depth) -> IO ()
cropImage image = do
    medianBlurred   <- return $ medianBlurImage image --image is (M.Mat (S '[height, width]) channels depth) and I need (M.Mat (S '[height, width]) (S channels) (S depth)), that's why M.unsafeCoerceMat 
    
    CV.withWindow "test" $ \window -> do
        CV.imshow window (CV.exceptError $ medianBlurred)
        void $ CV.waitKey 10000

Lib.hs

{-# LANGUAGE TypeFamilies #-}

module Lib
    ( controller
    ) where

import CropImage
import Utils
import Control.Monad ( void )
import Data.Word
import qualified OpenCV.Internal.Core.Types.Mat as M
import qualified OpenCV as CV
import qualified Data.ByteString as B

--controller :: (depth `CV.In` '[Word8, Word16, Float], channels `CV.In` '[1, 3, 4]) => IO (M.Mat shape ('CV.S channels) ('CV.S depth))
--controller :: (depth `CV.In` '[Word8, Word16, Float], channels `CV.In` '[1, 3, 4]) => IO (IO (M.Mat (CV.S '[height0, width0]) (CV.S channels) (CV.S depth)))
controller :: IO (IO ())
--controller :: IO()
controller = do
	file <- B.readFile "someImage.JPG"
	img <- return $ CV.imdecode CV.ImreadGrayscale file
	return $ cropImage (M.unsafeCoerceMat img)
	--putStrLn ("just testing")

simple.cabal

--My Cabal package
name:                simple
version:             0.1.0.0
synopsis:            Initial project template from stack
description:         Please see README.md
homepage:            https://github.com/githubuser/simple#readme
license:             BSD3
license-file:        LICENSE
author:              Author name here
maintainer:          [email protected]
copyright:           2016 Author name here
category:            Web
build-type:          Simple
-- extra-source-files:
cabal-version:       >=1.10

library
  hs-source-dirs:      src
  default-extensions:  BangPatterns
                       DataKinds
                       LambdaCase
                       OverloadedStrings
                       PackageImports
                       PolyKinds
                       ScopedTypeVariables
                       TupleSections
                       TypeFamilies
                       TypeOperators
  exposed-modules:     Lib
                     , CropImage
                     , Utils
  build-depends:       base >= 4.7 && < 5
                     , mtl
                     , opencv
                     , bytestring
                     , linear
  default-language:    Haskell2010

executable simple-exe
  hs-source-dirs:      app
  main-is:             Main.hs
 -- ghc-options:         -threaded -rtsopts -with-rtsopts=-N
  build-depends:       base
                     , simple
                     , opencv
                     , bytestring
                     , linear
  default-language:    Haskell2010

test-suite simple-test
  type:                exitcode-stdio-1.0
  hs-source-dirs:      test
  main-is:             Spec.hs
  build-depends:       base
                     , simple
                     , opencv
                     , bytestring
                     , linear
 -- ghc-options:         -threaded -rtsopts -with-rtsopts=-N
  default-language:    Haskell2010

source-repository head
  type:     git
  location: https://github.com/githubuser/simple

stack.yaml

# This file was automatically generated by 'stack init'
# 
# Some commonly used options have been documented as comments in this file.
# For advanced use and comprehensive documentation of the format, please see:
# http://docs.haskellstack.org/en/stable/yaml_configuration/

# Resolver to choose a 'specific' stackage snapshot or a compiler version.
# A snapshot resolver dictates the compiler version and the set of packages
# to be used for project dependencies. For example:
# 
# resolver: lts-3.5
# resolver: nightly-2015-09-21
# resolver: ghc-7.10.2
# resolver: ghcjs-0.1.0_ghc-7.10.2
# resolver:
#  name: custom-snapshot
#  location: "./custom-snapshot.yaml"
resolver: lts-6.17

# User packages to be built.
# Various formats can be used as shown in the example below.
# 
packages:
# - some-directory
# - https://example.com/foo/bar/baz-0.0.2.tar.gz
 - location:
    git: https://github.com/LumiGuide/haskell-opencv.git
    commit: 0d937f6bc13fc081d1a83ce87d8dcc482d11c977
 - '.'
# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a
#   extra-dep: true
#  subdirs:
#  - auto-update
#  - wai
# 
# A package marked 'extra-dep: true' will only be built if demanded by a
# non-dependency (i.e. a user package), and its test suites and benchmarks
# will not be run. This is useful for tweaking upstream packages.
# packages:
# - '.'
# Dependency packages to be pulled from upstream that are not in the resolver
# (e.g., acme-missiles-0.3)
extra-deps: []

# Override default flag values for local packages and extra-deps
flags: {}

# Extra package databases containing global packages
extra-package-dbs: []

# Control whether we use the GHC we find on the path
# system-ghc: true
# 
# Require a specific version of stack, using version ranges
# require-stack-version: -any # Default
# require-stack-version: ">=1.1"
# 
# Override the architecture used by stack, especially useful on Windows
# arch: i386
# arch: x86_64
# 
# Extra directories used by stack for building
# extra-include-dirs: [/path/to/dir]
# extra-lib-dirs: [/path/to/dir]
# 
# Allow a newer minor version of GHC than the snapshot specifies
# compiler-check: newer-minor

Utils.hs

module Utils
    ( 
      getHandW
    , getSize
    , getImageFromEither
    ) where

import Control.Monad ( void )
import qualified OpenCV as CV
import qualified OpenCV.Internal.Core.Types.Mat as M
import GHC.Int (Int32)
import Linear.V2

getHandW image = M.miShape $ M.matInfo image

getMonValue :: Maybe Int -> Int
getMonValue (Just x) = x

fromFractToInt :: (Num b, RealFrac a) => a -> b
fromFractToInt x = fromIntegral (truncate x) 

fromRight :: Either a b -> b
fromRight (Left _)  = error "fromRight: Argument takes form 'Left _'"
fromRight (Right x) = x

getSize :: Int32 -> Int32 -> Maybe Int -> Maybe Int -> V2 Int32
getSize w h wanted_w wanted_y 
    | wanted_w == Nothing = V2 (fromIntegral(((truncate ((fromIntegral w) * r1))))) (fromIntegral(getMonValue wanted_y))
    | wanted_y == Nothing = V2 (fromIntegral(getMonValue wanted_w)) (fromIntegral(((truncate ((fromIntegral h) * r2)))))
    | otherwise           = error "Either wanted_w or wanted_y should be a value"
    where 
        r1 = (fromIntegral (getMonValue wanted_y) / fromIntegral h)
        r2 = (fromIntegral (getMonValue wanted_w) / fromIntegral w)

getImageFromEither :: Either a b -> b
getImageFromEither eitherImage = fromRight eitherImage