diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,32 @@ +Copyright 2015–2017 Lumi Guide Fietsdetectie B.V. + +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. + + * The name Lumi Guide Fietsdetectie B.V. and the names of + contributors may NOT 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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,8 @@ +import Distribution.Simple ( defaultMainArgs ) +import System.Environment ( getArgs ) + +main = do + args <- getArgs + let args' | "configure" `elem` args = args ++ ["--with-gcc","g++", "--with-ld","g++"] + | otherwise = args + defaultMainArgs args' diff --git a/doc/ExampleExtractor.hs b/doc/ExampleExtractor.hs new file mode 100644 --- /dev/null +++ b/doc/ExampleExtractor.hs @@ -0,0 +1,350 @@ +{-# language QuasiQuotes #-} +{-# language TemplateHaskell #-} + +module ExampleExtractor + ( Animation + + , renderImage + , renderAnimation + + , extractExampleImages + ) where + +import "base" Control.Arrow ( (***), (&&&) ) +import "base" Control.Monad +import "base" Data.Bifunctor +import "base" Data.Either +import "base" Data.Maybe +import "base" Data.Monoid +import "base" Data.Word +import qualified "containers" Data.Map.Strict as M +import "directory" System.Directory ( canonicalizePath ) +import qualified "haskell-src-exts" Language.Haskell.Exts.Extension as Hse +import qualified "haskell-src-exts" Language.Haskell.Exts.Parser as Hse +import qualified "haskell-src-exts" Language.Haskell.Exts.Syntax as Hse +import qualified "haskell-src-exts" Language.Haskell.Exts.SrcLoc as Hse +import qualified "Glob" System.FilePath.Glob as G +import "JuicyPixels" Codec.Picture.ColorQuant as JP +import "JuicyPixels" Codec.Picture.Gif as JP +import "JuicyPixels" Codec.Picture.Types as JP +import qualified "opencv" OpenCV as CV +import qualified "opencv" OpenCV.Juicy as CVJ +import qualified "text" Data.Text as T +import qualified "text" Data.Text.IO as T +import qualified "bytestring" Data.ByteString as B +import qualified "bytestring" Data.ByteString.Lazy as BL +import "template-haskell" Language.Haskell.TH +import "template-haskell" Language.Haskell.TH.Syntax +import "this" Language.Haskell.Meta.Syntax.Translate ( toDecs ) + +-------------------------------------------------------------------------------- + +-- An animation is a list of images. Each image has a duration +-- specified in hundreths of a second. +type Animation shape channels depth = [(Int, CV.Mat shape channels depth)] + +-------------------------------------------------------------------------------- + +renderImage + :: FilePath + -> CV.Mat ('CV.S [height, width]) channels depth + -> IO () +renderImage fp img = do + let bs = CV.exceptError $ CV.imencode (CV.OutputPng CV.defaultPngParams) img + putStr $ "Writing image " <> dest <> " ..." + B.writeFile dest bs + putStrLn " OK" + where + dest = mkDestPath fp + +renderAnimation + :: FilePath + -> Animation ('CV.S [height, width]) ('CV.S 3) ('CV.S Word8) + -> IO () +renderAnimation fp imgs = do + putStr $ "Writing animation " <> dest <> " ..." + case gif of + Left errMsg -> putStrLn $ " " <> errMsg + Right bs -> BL.writeFile dest bs + putStrLn " OK" + where + gif :: Either String BL.ByteString + gif = JP.encodeGifImages JP.LoopingForever palImgs + + palImgs :: [(JP.Palette, JP.GifDelay, JP.Image JP.Pixel8)] + palImgs = + map (\(delay, img) -> + let (img8, pal) = JP.palettize JP.defaultPaletteOptions img + in (pal, delay, img8) + ) + jpImgs + + jpImgs :: [(JP.GifDelay, JP.Image JP.PixelRGB8)] + jpImgs = map (second CVJ.toImage) imgs + + dest = mkDestPath fp + +mkDestPath :: FilePath -> FilePath +mkDestPath fp = "doc/generated/" <> fp + +-------------------------------------------------------------------------------- + +data SrcLoc + = SrcLoc + { locFile :: !FilePath + , locLine :: !Int + } + +-- | Haskell source code containing 0, 1 or more examples. +data ExampleSrc + = ExampleSrc + { exsLoc :: !SrcLoc + , exsSrc :: !T.Text + } + +data ParsedExampleSrc + = ParsedExampleSrc + { pexsLoc :: !SrcLoc + , pexsDecls :: ![Dec] + } + +-- | A single line of Haskell source code. +data SrcLine + = SrcLine + { srcLoc :: !SrcLoc + , srcLine :: !T.Text + } + +data SymbolType + = SymImage + | SymImageAction + deriving (Show, Eq) + +data ExampleProps + = ExampleProps + { exPropIO :: !Bool + , exPropAnimation :: !Bool + } deriving Show + +data RenderTarget + = RenderTarget + { rtDestination :: !FilePath + -- ^ Relative path where the symbol must be rendered as an image file. + , rtSymbolName :: !Name + -- ^ Name of a top level symbol (function or CAF) that is either an image + -- or an IO action that yields an image. + , rtSymbolProps :: !ExampleProps + } deriving Show + +-------------------------------------------------------------------------------- + +extractExampleImages :: FilePath -> Q [Dec] +extractExampleImages srcDir = do + haskellPaths <- runIO $ findHaskellPaths srcDir + mapM_ (addDependentFile <=< runIO . canonicalizePath) haskellPaths + + ((exampleSrcs, renderTargets) :: ([ExampleSrc], [RenderTarget])) <- runIO $ do + xs <- mapM findExamples haskellPaths + pure $ (concat *** concat) $ unzip xs + + let parseErrors :: [String] + parsedExampleSrcs :: [ParsedExampleSrc] + (parseErrors, parsedExampleSrcs) = partitionEithers $ map parseExampleSrc exampleSrcs + + examplesTH :: [Dec] + examplesTH = concatMap (\pexs -> parsedExampleLinePragma pexs : pexsDecls pexs) + parsedExampleSrcs + + exampleTypes :: M.Map Name Type + exampleTypes = M.fromList $ mapMaybe asSigD examplesTH + + renderTargets' :: [RenderTarget] + renderTargets' = + mapMaybe + (\rt -> do + exampleType <- M.lookup (rtSymbolName rt) exampleTypes + pure rt {rtSymbolProps = classifyExample exampleType} + ) + renderTargets + + unless (null parseErrors) $ + error $ show parseErrors + + mdecs <- mkRenderExampleImages renderTargets' + pure $ examplesTH <> mdecs + +parsedExampleLinePragma :: ParsedExampleSrc -> Dec +parsedExampleLinePragma pexs = + PragmaD $ LineP (locLine loc) (locFile loc) + where + loc = pexsLoc pexs + +parseExampleSrc :: ExampleSrc -> Either String ParsedExampleSrc +parseExampleSrc exs = + case parseDecsHse (locFile $ exsLoc exs) $ T.unpack $ haddockToHaskell $ exsSrc exs of + Left errMsg -> Left $ (locFile $ exsLoc exs) <> ": " <> errMsg + Right decls -> Right + ParsedExampleSrc + { pexsLoc = exsLoc exs + , pexsDecls = toDecs decls + } + + +asSigD :: Dec -> Maybe (Name, Type) +asSigD (SigD n t) = Just (n, t) +asSigD _ = Nothing + +-- Really hacky way of determining the properties of an example based +-- on its type. +classifyExample :: Type -> ExampleProps +classifyExample (ForallT _ _ t) = classifyExample t +classifyExample (AppT (ConT n) t2) | nameBase n == nameBase ''IO = checkIOAnimation t2 +classifyExample (AppT t1 _) = classifyExample t1 +classifyExample (VarT _) = ExampleProps False False +classifyExample (ConT n) | nameBase n == nameBase ''Animation = ExampleProps False True +classifyExample (PromotedT _) = ExampleProps False False +classifyExample _ = ExampleProps False False + +checkIOAnimation :: Type -> ExampleProps +checkIOAnimation (ForallT _ _ t) = checkIOAnimation t +checkIOAnimation (AppT t1 _) = checkIOAnimation t1 +checkIOAnimation (VarT _) = ExampleProps True False +checkIOAnimation (ConT n) | nameBase n == nameBase ''Animation = ExampleProps True True +checkIOAnimation (PromotedT _) = ExampleProps True False +checkIOAnimation _ = ExampleProps True False + +parseDecsHse :: String -> String -> Either String [Hse.Decl Hse.SrcSpanInfo] +parseDecsHse fileName str = + case Hse.parseModuleWithMode (parseMode fileName) str of + Hse.ParseFailed _srcLoc err -> Left err + Hse.ParseOk (Hse.Module _ _ _ _ decls) -> Right decls + Hse.ParseOk _ -> Left "Invalid module" + +parseMode :: String -> Hse.ParseMode +parseMode fileName = + Hse.ParseMode + { Hse.parseFilename = fileName + , Hse.baseLanguage = Hse.Haskell2010 + , Hse.extensions = map Hse.EnableExtension exts + , Hse.ignoreLanguagePragmas = False + , Hse.ignoreLinePragmas = False + , Hse.fixities = Nothing + , Hse.ignoreFunctionArity = False + } + where + exts :: [Hse.KnownExtension] + exts = + [ Hse.BangPatterns + , Hse.DataKinds + , Hse.FlexibleContexts + , Hse.LambdaCase + , Hse.OverloadedStrings + , Hse.PackageImports + , Hse.PolyKinds + , Hse.ScopedTypeVariables + , Hse.TupleSections + , Hse.TypeFamilies + , Hse.TypeOperators + , Hse.PostfixOperators + , Hse.QuasiQuotes + , Hse.UnicodeSyntax + , Hse.MagicHash + , Hse.PatternSignatures + , Hse.MultiParamTypeClasses + , Hse.RankNTypes + ] + +-- | Generate code for every render target +-- +-- Executing the generated code will actually render the target. +mkRenderExampleImages :: [RenderTarget] -> Q [Dec] +mkRenderExampleImages renderTargets = [d| + renderExampleImages :: IO () + renderExampleImages = $(pure doRender) + |] + where + doRender :: Exp + doRender = + DoE $ do + rt <- renderTargets + let sym = VarE $ rtSymbolName rt + fp = LitE $ StringL $ "examples/" <> rtDestination rt + props = rtSymbolProps rt + render | exPropAnimation props = 'renderAnimation + | otherwise = 'renderImage + pure $ NoBindS $ + if exPropIO props + then VarE '(>>=) `AppE` sym `AppE` (VarE render `AppE` fp) + else VarE render `AppE` fp `AppE` sym + +findHaskellPaths :: FilePath -> IO [FilePath] +findHaskellPaths srcDir = do + (paths, _) <- G.globDir [G.compile "**/*.hs", G.compile "**/*.hsc"] srcDir + pure $ concat paths + +haddockToHaskell :: T.Text -> T.Text +haddockToHaskell = + T.replace "\\\\" "\\" + . T.replace "\\`" "`" + . T.replace "\\<" "<" + . T.replace "\\/" "/" + +findExamples :: FilePath -> IO ([ExampleSrc], [RenderTarget]) +findExamples fp = ((parseExamples &&& parseGeneratedImages) . textToSource fp) <$> T.readFile fp + +textToSource :: FilePath -> T.Text -> [SrcLine] +textToSource fp txt = zipWith lineToSource [1..] (T.lines txt) + where + lineToSource :: Int -> T.Text -> SrcLine + lineToSource n line = + SrcLine + { srcLoc = SrcLoc {locFile = fp, locLine = n} + , srcLine = line + } + +parseExamples :: [SrcLine] -> [ExampleSrc] +parseExamples = findStart + where + findStart :: [SrcLine] -> [ExampleSrc] + findStart [] = [] + findStart (_:[]) = [] + findStart (_:_:[]) = [] + findStart (a:b:c:ls) + | srcLine a == "Example:" + , srcLine b == "" + , srcLine c == "@" + = findEnd [] ls + findStart (_:ls) = findStart ls + + findEnd :: [SrcLine] -> [SrcLine] -> [ExampleSrc] + findEnd _acc [] = [] + findEnd acc (l:ls) + | srcLine l == "@" = + case reverse acc of + [] -> findStart ls + revAcc@(firstLine:_) -> + let exs = ExampleSrc + { exsLoc = srcLoc firstLine + , exsSrc = T.unlines (map srcLine revAcc) + } + in exs : findStart ls + | otherwise = findEnd (l:acc) ls + +parseGeneratedImages :: [SrcLine] -> [RenderTarget] +parseGeneratedImages = concatMap $ parseLine . srcLine + where + parseLine :: T.Text -> [RenderTarget] + parseLine line = maybeToList $ do + let fromPrefix = snd $ T.breakOn prefix line + rest <- T.stripPrefix prefix fromPrefix + case take 2 $ T.words rest of + [fp, funcName] -> + pure RenderTarget + { rtDestination = T.unpack $ fp + , rtSymbolName = mkName $ T.unpack $ fromMaybe funcName (T.stripSuffix ">>" funcName) + -- Later on we will determine the actual properties. + , rtSymbolProps = ExampleProps False False + } + _ -> Nothing + + prefix = "< + Stability : experimental + Portability : portable (template-haskell) +-} + +module Language.Haskell.Meta.Syntax.Translate ( + module Language.Haskell.Meta.Syntax.Translate +) where + +import Data.Char (ord, isUpper) +import Data.Typeable +import Data.List (foldl', nub, (\\)) +import Language.Haskell.TH.Syntax +import qualified Language.Haskell.Exts.SrcLoc as Hs +#if MIN_VERSION_haskell_src_exts(1,18,0) +import qualified Language.Haskell.Exts.Syntax as Hs +#else +import qualified Language.Haskell.Exts.Annotated.Syntax as Hs +#endif + +----------------------------------------------------------------------------- + + +class ToName a where toName :: a -> Name +class ToNames a where toNames :: a -> [Name] +class ToLit a where toLit :: a -> Lit +class ToType a where toType :: a -> Type +class ToPat a where toPat :: a -> Pat +class ToExp a where toExp :: a -> Exp +class ToDecs a where toDecs :: a -> [Dec] +class ToDec a where toDec :: a -> Dec +class ToStmt a where toStmt :: a -> Stmt +class ToLoc a where toLoc :: a -> Loc +class ToCxt a where toCxt :: a -> Cxt +class ToPred a where toPred :: a -> Pred +class ToTyVars a where toTyVars :: a -> [TyVarBndr] +#if MIN_VERSION_haskell_src_exts(1,18,0) +class ToMaybeKind a where toMaybeKind :: a -> Maybe Kind +#if MIN_VERSION_template_haskell(2,11,0) +class ToInjectivityAnn a where toInjectivityAnn :: a -> InjectivityAnn +#endif +#endif + +-- for error messages +moduleName = "Language.Haskell.Meta.Syntax.Translate" + +-- When to use each of these isn't always clear: prefer 'todo' if unsure. +noTH :: (Functor f, Show (f ())) => String -> f e -> a +noTH fun thing = error . concat $ [moduleName, ".", fun, + ": template-haskell has no representation for: ", show (fmap (const ()) thing)] + +noTHyet :: (Functor f, Show (f ())) => String -> String -> f e -> a +noTHyet fun minVersion thing = error . concat $ [moduleName, ".", fun, + ": template-haskell-", VERSION_template_haskell, " (< ", minVersion, ")", + " has no representation for: ", show (fmap (const ()) thing)] + +todo :: (Functor f, Show (f ())) => String -> f e -> a +todo fun thing = error . concat $ [moduleName, ".", fun, + ": not implemented: ", show (fmap (const ()) thing)] + +nonsense :: (Functor f, Show (f ())) => String -> String -> f e -> a +nonsense fun inparticular thing = error . concat $ [moduleName, ".", fun, + ": nonsensical: ", inparticular, ": ", show (fmap (const ()) thing)] + +----------------------------------------------------------------------------- + + +instance ToExp Lit where + toExp = LitE +instance (ToExp a) => ToExp [a] where + toExp = ListE . fmap toExp +instance (ToExp a, ToExp b) => ToExp (a,b) where + toExp (a,b) = TupE [toExp a, toExp b] +instance (ToExp a, ToExp b, ToExp c) => ToExp (a,b,c) where + toExp (a,b,c) = TupE [toExp a, toExp b, toExp c] +instance (ToExp a, ToExp b, ToExp c, ToExp d) => ToExp (a,b,c,d) where + toExp (a,b,c,d) = TupE [toExp a, toExp b, toExp c, toExp d] + + +instance ToPat Lit where + toPat = LitP +instance (ToPat a) => ToPat [a] where + toPat = ListP . fmap toPat +instance (ToPat a, ToPat b) => ToPat (a,b) where + toPat (a,b) = TupP [toPat a, toPat b] +instance (ToPat a, ToPat b, ToPat c) => ToPat (a,b,c) where + toPat (a,b,c) = TupP [toPat a, toPat b, toPat c] +instance (ToPat a, ToPat b, ToPat c, ToPat d) => ToPat (a,b,c,d) where + toPat (a,b,c,d) = TupP [toPat a, toPat b, toPat c, toPat d] + + +instance ToLit Char where + toLit = CharL +instance ToLit String where + toLit = StringL +instance ToLit Integer where + toLit = IntegerL +instance ToLit Int where + toLit = IntegerL . toInteger +instance ToLit Float where + toLit = RationalL . toRational +instance ToLit Double where + toLit = RationalL . toRational + + +----------------------------------------------------------------------------- + + +-- * ToName {String,HsName,Module,HsSpecialCon,HsQName} + + +instance ToName String where + toName = mkName + +instance ToName (Hs.Name l) where + toName (Hs.Ident _ s) = toName s + toName (Hs.Symbol _ s) = toName s + +instance ToName (Hs.SpecialCon l) where + toName (Hs.UnitCon _) = '() + toName (Hs.ListCon _) = '[] + toName (Hs.FunCon _) = ''(->) + toName (Hs.TupleCon _ _ n) + | n<2 = '() + | otherwise = + let x = maybe [] (++".") (nameModule '(,)) + in mkName . concat $ x : ["(",replicate (n-1) ',',")"] + toName (Hs.Cons _) = '(:) + + +instance ToName (Hs.QName l) where +-- toName (Hs.Qual (Hs.Module []) n) = toName n + toName (Hs.Qual _ (Hs.ModuleName _ []) n) = toName n + toName (Hs.Qual _ (Hs.ModuleName _ m) n) = + let m' = show . toName $ m + n' = show . toName $ n + in toName . concat $ [m',".",n'] + toName (Hs.UnQual _ n) = toName n + toName (Hs.Special _ s) = toName s + + +instance ToName (Hs.Op l) where + toName (Hs.VarOp _ n) = toName n + toName (Hs.ConOp _ n) = toName n + + +----------------------------------------------------------------------------- + +-- * ToLit HsLiteral + + +instance ToLit (Hs.Literal l) where + toLit (Hs.Char _ a _) = CharL a + toLit (Hs.String _ a _) = StringL a + toLit (Hs.Int _ a _) = IntegerL a + toLit (Hs.Frac _ a _) = RationalL a + toLit l@Hs.PrimChar{} = noTH "toLit" l + toLit (Hs.PrimString _ a _) = StringPrimL (map toWord8 a) + where + toWord8 = fromIntegral . ord + toLit (Hs.PrimInt _ a _) = IntPrimL a + toLit (Hs.PrimFloat _ a _) = FloatPrimL a + toLit (Hs.PrimDouble _ a _) = DoublePrimL a + toLit (Hs.PrimWord _ a _) = WordPrimL a + + +----------------------------------------------------------------------------- + +-- * ToPat HsPat + + +instance ToPat (Hs.Pat l) where + toPat (Hs.PVar _ n) + = VarP (toName n) + toPat (Hs.PLit _ (Hs.Signless _) l) + = LitP (toLit l) + toPat (Hs.PLit _ (Hs.Negative _) l) = LitP $ case toLit l of + IntegerL z -> IntegerL (negate z) + RationalL q -> RationalL (negate q) + IntPrimL z' -> IntPrimL (negate z') + FloatPrimL r' -> FloatPrimL (negate r') + DoublePrimL r'' -> DoublePrimL (negate r'') + _ -> nonsense "toPat" "negating wrong kind of literal" l + toPat (Hs.PInfixApp _ p n q) = UInfixP (toPat p) (toName n) (toPat q) + toPat (Hs.PApp _ n ps) = ConP (toName n) (fmap toPat ps) + toPat (Hs.PTuple _ Hs.Boxed ps) = TupP (fmap toPat ps) + toPat (Hs.PTuple _ Hs.Unboxed ps) = UnboxedTupP (fmap toPat ps) + toPat (Hs.PList _ ps) = ListP (fmap toPat ps) + toPat (Hs.PParen _ p) = ParensP (toPat p) + toPat (Hs.PRec _ n pfs) = let toFieldPat (Hs.PFieldPat _ n p) = (toName n, toPat p) + in RecP (toName n) (fmap toFieldPat pfs) + toPat (Hs.PAsPat _ n p) = AsP (toName n) (toPat p) + toPat (Hs.PWildCard _) = WildP + toPat (Hs.PIrrPat _ p) = TildeP (toPat p) + toPat (Hs.PatTypeSig _ p t) = SigP (toPat p) (toType t) + toPat (Hs.PViewPat _ e p) = ViewP (toExp e) (toPat p) + -- regular pattern + toPat p@Hs.PRPat{} = noTH "toPat" p + -- XML stuff + toPat p@Hs.PXTag{} = noTH "toPat" p + toPat p@Hs.PXETag{} = noTH "toPat" p + toPat p@Hs.PXPcdata{} = noTH "toPat" p + toPat p@Hs.PXPatTag{} = noTH "toPat" p + toPat (Hs.PBangPat _ p) = BangP (toPat p) + toPat p = todo "toPat" p + +----------------------------------------------------------------------------- + +-- * ToExp HsExp + +instance ToExp (Hs.QOp l) where + toExp (Hs.QVarOp _ n) = VarE (toName n) + toExp (Hs.QConOp _ n) = ConE (toName n) + +toFieldExp :: Hs.FieldUpdate l -> FieldExp +toFieldExp (Hs.FieldUpdate _ n e) = (toName n, toExp e) + + + + +instance ToExp (Hs.Exp l) where + toExp (Hs.Var _ n) = VarE (toName n) + toExp e@Hs.IPVar{} = noTH "toExp" e + toExp (Hs.Con _ n) = ConE (toName n) + toExp (Hs.Lit _ l) = LitE (toLit l) + toExp (Hs.InfixApp _ e o f) = UInfixE (toExp e) (toExp o) (toExp f) + toExp (Hs.App _ e f) = AppE (toExp e) (toExp f) + toExp (Hs.NegApp _ e) = AppE (VarE 'negate) (toExp e) + toExp (Hs.Lambda _ ps e) = LamE (fmap toPat ps) (toExp e) + toExp (Hs.Let _ bs e) = LetE (toDecs bs) (toExp e) + toExp (Hs.If _ a b c) = CondE (toExp a) (toExp b) (toExp c) + toExp (Hs.MultiIf _ ifs) = MultiIfE (map toGuard ifs) + toExp (Hs.Case _ e alts) = CaseE (toExp e) (map toMatch alts) + toExp (Hs.Do _ ss) = DoE (map toStmt ss) + toExp e@(Hs.MDo _ _) = noTH "toExp" e + toExp (Hs.Tuple _ Hs.Boxed xs) = TupE (fmap toExp xs) + toExp (Hs.Tuple _ Hs.Unboxed xs) = UnboxedTupE (fmap toExp xs) + toExp e@Hs.TupleSection{} = noTH "toExp" e + toExp (Hs.List _ xs) = ListE (fmap toExp xs) + toExp (Hs.Paren _ e) = ParensE (toExp e) + toExp (Hs.LeftSection _ e o) = InfixE (Just . toExp $ e) (toExp o) Nothing + toExp (Hs.RightSection _ o f) = InfixE Nothing (toExp o) (Just . toExp $ f) + toExp (Hs.RecConstr _ n xs) = RecConE (toName n) (fmap toFieldExp xs) + toExp (Hs.RecUpdate _ e xs) = RecUpdE (toExp e) (fmap toFieldExp xs) + toExp (Hs.EnumFrom _ e) = ArithSeqE $ FromR (toExp e) + toExp (Hs.EnumFromTo _ e f) = ArithSeqE $ FromToR (toExp e) (toExp f) + toExp (Hs.EnumFromThen _ e f) = ArithSeqE $ FromThenR (toExp e) (toExp f) + toExp (Hs.EnumFromThenTo _ e f g) = ArithSeqE $ FromThenToR (toExp e) (toExp f) (toExp g) + toExp (Hs.ListComp _ e ss) = CompE $ map convert ss ++ [NoBindS (toExp e)] + where + convert (Hs.QualStmt _ st) = toStmt st + convert s = noTH "toExp ListComp" s + toExp (Hs.ExpTypeSig _ e t) = SigE (toExp e) (toType t) + toExp e = todo "toExp" e + + +toMatch :: Hs.Alt l -> Match +toMatch (Hs.Alt _ p rhs ds) = Match (toPat p) (toBody rhs) (toDecs ds) + +toBody :: Hs.Rhs l -> Body +toBody (Hs.UnGuardedRhs _ e) = NormalB $ toExp e +toBody (Hs.GuardedRhss _ rhss) = GuardedB $ map toGuard rhss + +toGuard (Hs.GuardedRhs _ stmts e) = (g, toExp e) + where + g = case map toStmt stmts of + [NoBindS x] -> NormalG x + xs -> PatG xs + +instance ToDecs a => ToDecs (Maybe a) where + toDecs Nothing = [] + toDecs (Just a) = toDecs a + +instance ToDecs (Hs.Binds l) where + toDecs (Hs.BDecls _ ds) = toDecs ds + toDecs a@(Hs.IPBinds {}) = noTH "ToDecs Hs.Binds" a + +instance ToDecs (Hs.ClassDecl l) where + toDecs (Hs.ClsDecl _ d) = toDecs d + toDecs x = todo "classDecl" x + +----------------------------------------------------------------------------- + +-- * ToLoc SrcLoc + +instance ToLoc Hs.SrcLoc where + toLoc (Hs.SrcLoc fn l c) = + Loc fn [] [] (l,c) (-1,-1) + +----------------------------------------------------------------------------- + +-- * ToType HsType + +instance ToName (Hs.TyVarBind l) where + toName (Hs.KindedVar _ n _) = toName n + toName (Hs.UnkindedVar _ n) = toName n + +instance ToName Name where + toName = id + +instance ToName TyVarBndr where + toName (PlainTV n) = n + toName (KindedTV n _) = n + +instance ToType (Hs.Kind l) where + toType (Hs.KindStar _) = StarT + toType (Hs.KindFn _ k1 k2) = toType k1 .->. toType k2 + toType (Hs.KindParen _ kp) = toType kp + toType (Hs.KindVar _ n) + | isCon (nameBase th_n) = ConT th_n + | otherwise = VarT th_n + where + th_n = toName n + + isCon :: String -> Bool + isCon (c:_) = isUpper c || c == ':' + isCon _ = nonsense "toType" "empty kind variable name" n + toType (Hs.KindApp _ k1 k2) = toType k1 `AppT` toType k2 + toType (Hs.KindTuple _ ks) = foldr (\k pt -> pt `AppT` toType k) (TupleT $ length ks) ks + toType (Hs.KindList _ k) = ListT `AppT` toType k + +toKind :: Hs.Kind l -> Kind +toKind = toType + +toTyVar :: Hs.TyVarBind l -> TyVarBndr +toTyVar (Hs.KindedVar _ n k) = KindedTV (toName n) (toKind k) +toTyVar (Hs.UnkindedVar _ n) = PlainTV (toName n) + +instance ToType (Hs.Type l) where + toType (Hs.TyForall _ tvbM cxt t) = ForallT (maybe [] (fmap toTyVar) tvbM) (toCxt cxt) (toType t) + toType (Hs.TyFun _ a b) = toType a .->. toType b + toType (Hs.TyList _ t) = ListT `AppT` toType t + toType (Hs.TyTuple _ b ts) = foldAppT (tuple . length $ ts) (fmap toType ts) + where + tuple = case b of + Hs.Boxed -> TupleT + Hs.Unboxed -> UnboxedTupleT + toType (Hs.TyApp _ a b) = AppT (toType a) (toType b) + toType (Hs.TyVar _ n) = VarT (toName n) + toType (Hs.TyCon _ qn) = ConT (toName qn) + toType (Hs.TyParen _ t) = toType t + -- XXX: need to wrap the name in parens! + toType (Hs.TyInfix _ a o b) = AppT (AppT (ConT (toName o)) (toType a)) (toType b) + toType (Hs.TyKind _ t k) = SigT (toType t) (toKind k) + toType (Hs.TyPromoted _ p) = + case p of + Hs.PromotedInteger _ i _ -> LitT $ NumTyLit i + Hs.PromotedString _ _ s -> LitT $ StrTyLit s + Hs.PromotedCon _ _q n -> PromotedT (toName n) + Hs.PromotedList _ _q ts -> foldr (\t pl -> PromotedConsT `AppT` toType t `AppT` pl) PromotedNilT ts + Hs.PromotedTuple _ ts -> foldr (\t pt -> pt `AppT` toType t) (PromotedTupleT $ length ts) ts + Hs.PromotedUnit _ -> PromotedT ''() + toType (Hs.TyEquals _ t1 t2) = EqualityT `AppT` toType t1 `AppT` toType t2 + toType t@(Hs.TySplice _ _) = noTH "toType" t + toType t@Hs.TyBang{} = + nonsense "toType" "type cannot have strictness annotations in this context" t + toType t@(Hs.TyWildCard _ _) = noTH "toType" t + toType t = todo "toType" t + +toStrictType :: Hs.Type l -> StrictType +#if MIN_VERSION_haskell_src_exts(1,18,0) +#if MIN_VERSION_template_haskell(2,11,0) +toStrictType (Hs.TyBang _ s u t) = (Bang (toUnpack u) (toStrict s), toType t) + where + toStrict (Hs.LazyTy _) = SourceLazy + toStrict (Hs.BangedTy _) = SourceStrict + toStrict (Hs.NoStrictAnnot _) = NoSourceStrictness + toUnpack (Hs.Unpack _) = SourceUnpack + toUnpack (Hs.NoUnpack _) = SourceNoUnpack + toUnpack (Hs.NoUnpackPragma _) = NoSourceUnpackedness +toStrictType x = (Bang NoSourceUnpackedness NoSourceStrictness, toType x) +#else +-- TyBang l (BangType l) (Unpackedness l) (Type l) +-- data BangType l = BangedTy l | LazyTy l | NoStrictAnnot l +-- data Unpackedness l = Unpack l | NoUnpack l | NoUnpackPragma l +toStrictType (Hs.TyBang _ b u t) = (toStrict b u, toType t) + where + toStrict :: Hs.BangType l -> Hs.Unpackedness l -> Strict + toStrict (Hs.BangedTy _) _ = IsStrict + toStrict _ (Hs.Unpack _) = Unpacked + toStrict _ _ = NotStrict +toStrictType x = (NotStrict, toType x) +#endif +#else +#if MIN_VERSION_template_haskell(2,11,0) +toStrictType (Hs.TyBang _ (Hs.UnpackedTy _) t) = toStrictType2 SourceUnpack t +toStrictType t = toStrictType2 NoSourceUnpackedness t + +toStrictType2 u t@(Hs.TyBang _ _ Hs.TyBang{}) = + nonsense "toStrictType" "double strictness annotation" t +toStrictType2 u (Hs.TyBang _ (Hs.BangedTy _) t) = (Bang u SourceStrict, toType t) +toStrictType2 u (Hs.TyBang _ (Hs.UnpackedTy _) t) = + nonsense "toStrictType" "double unpackedness annotation" t +toStrictType2 u t = (Bang u NoSourceStrictness, toType t) +#else /* !MIN_VERSION_template_haskell(2,11,0) */ +toStrictType t@(Hs.TyBang _ _ Hs.TyBang{}) = + nonsense "toStrictType" "double strictness annotation" t +toStrictType (Hs.TyBang _ (Hs.BangedTy _) t) = (IsStrict, toType t) +toStrictType (Hs.TyBang _ (Hs.UnpackedTy _) t) = (Unpacked, toType t) +toStrictType t = (NotStrict, toType t) +#endif /* !MIN_VERSION_template_haskell(2,11,0) */ +#endif + + +(.->.) :: Type -> Type -> Type +a .->. b = AppT (AppT ArrowT a) b + +instance ToPred (Hs.Asst l) where +#if MIN_VERSION_template_haskell(2,10,0) + toPred (Hs.ClassA _ n ts) = foldl' AppT (ConT (toName n)) (fmap toType ts) + toPred (Hs.InfixA _ t1 n t2) = foldl' AppT (ConT (toName n)) (fmap toType [t1,t2]) + toPred (Hs.EqualP _ t1 t2) = foldl' AppT EqualityT (fmap toType [t1,t2]) + toPred (Hs.ParenA _ asst) = toPred asst + toPred a@Hs.AppA{} = todo "toCxt" a + toPred a@Hs.WildCardA{} = todo "toCxt" a +#else + toPred (Hs.ClassA _ n ts) = ClassP (toName n) (fmap toType ts) + toPred (Hs.InfixA _ t1 n t2) = ClassP (toName n) (fmap toType [t1, t2]) + toPred (Hs.EqualP _ t1 t2) = EqualP (toType t1) (toType t2) +#endif + toPred a@Hs.IParam{} = noTH "toCxt" a + toPred p = todo "toPred" p + +#if MIN_VERSION_template_haskell(2,11,0) +instance ToCxt (Hs.Deriving l) where + toCxt (Hs.Deriving _ rule) = toCxt rule +instance ToCxt [Hs.InstRule l] where + toCxt = concatMap toCxt +#endif + +instance ToCxt a => ToCxt (Maybe a) where + toCxt Nothing = [] + toCxt (Just a) = toCxt a + +foldAppT :: Type -> [Type] -> Type +foldAppT t ts = foldl' AppT t ts + +----------------------------------------------------------------------------- + +-- * ToStmt HsStmt + +instance ToStmt (Hs.Stmt l) where + toStmt (Hs.Generator _ p e) = BindS (toPat p) (toExp e) + toStmt (Hs.Qualifier _ e) = NoBindS (toExp e) + toStmt a@(Hs.LetStmt _ bnds) = LetS (toDecs bnds) + toStmt s@Hs.RecStmt{} = noTH "toStmt" s + + +----------------------------------------------------------------------------- + +-- * ToDec HsDecl + +instance ToDec (Hs.Decl l) where + toDec (Hs.TypeDecl _ h t) + = TySynD (toName h) (toTyVars h) (toType t) + + toDec a@(Hs.DataDecl _ dOrN cxt h qcds qns) + = case dOrN of + Hs.DataType _ -> DataD (toCxt cxt) + (toName h) + (toTyVars h) +#if MIN_VERSION_template_haskell(2,11,0) + Nothing +#endif + (fmap qualConDeclToCon qcds) +#if MIN_VERSION_template_haskell(2,11,0) + -- Convert a Deriving into a list of types, one for each derived class + -- Assumes that the types do not have any contexts + (maybe [] (\(Hs.Deriving _ q) -> map toType q) qns) +#else + (toNames qns) +#endif + Hs.NewType _ -> let qcd = case qcds of + [x] -> x + _ -> nonsense "toDec" ("newtype with " ++ + "wrong number of constructors") a + in NewtypeD (toCxt cxt) + (toName h) + (toTyVars h) +#if MIN_VERSION_template_haskell(2,11,0) + Nothing +#endif + (qualConDeclToCon qcd) +#if MIN_VERSION_template_haskell(2,11,0) + (maybe [] (\(Hs.Deriving _ q) -> map toType q) qns) +#else + (toNames qns) +#endif + + -- This type-signature conversion is just wrong. + -- Type variables need to be dealt with. /Jonas + toDec a@(Hs.TypeSig _ ns t) + -- XXXXXXXXXXXXXX: oh crap, we can't return a [Dec] from this class! + = let xs = fmap (flip SigD (toType t) . toName) ns + in case xs of x:_ -> x; [] -> error "toDec: malformed TypeSig!" + + toDec (Hs.InlineConlikeSig _ act qn) = PragmaD $ + InlineP (toName qn) Inline ConLike (transAct act) + toDec (Hs.InlineSig _ b act qn) = PragmaD $ + InlineP (toName qn) inline FunLike (transAct act) + where + inline | b = Inline | otherwise = NoInline + +#if MIN_VERSION_template_haskell(2,11,0) +#if MIN_VERSION_haskell_src_exts(1,18,0) + toDec (Hs.TypeFamDecl _ h sig inj) + = OpenTypeFamilyD $ TypeFamilyHead (toName h) + (toTyVars h) + (maybe NoSig KindSig . toMaybeKind $ sig) + (fmap toInjectivityAnn inj) + toDec (Hs.DataFamDecl _ _ h sig) + = DataFamilyD (toName h) (toTyVars h) (toMaybeKind sig) +#else + toDec (Hs.TypeFamDecl _ h k) + = OpenTypeFamilyD $ TypeFamilyHead (toName h) + (toTyVars h) + (maybe NoSig (KindSig . toKind) k) + Nothing + -- TODO: do something with context? + toDec (Hs.DataFamDecl _ _ h k) + = DataFamilyD (toName h) (toTyVars h) (fmap toKind k) +#endif + +#else +#if MIN_VERSION_haskell_src_exts(1,18,0) + toDec (Hs.TypeFamDecl _ h sig inj) + = FamilyD TypeFam (toName h) (toTyVars h) (toMaybeKind sig) + toDec (Hs.DataFamDecl _ _ h sig) + = FamilyD DataFam (toName h) (toTyVars h) (toMaybeKind sig) +#else + toDec (Hs.TypeFamDecl _ h k) + = FamilyD TypeFam (toName h) (toTyVars h) (fmap toKind k) + + -- TODO: do something with context? + toDec (Hs.DataFamDecl _ _ h k) + = FamilyD DataFam (toName h) (toTyVars h) (fmap toKind k) +#endif +#endif /* MIN_VERSION_template_haskell(2,11,0) */ + + toDec a@(Hs.FunBind _ mtchs) = hsMatchesToFunD mtchs + toDec (Hs.PatBind _ p rhs bnds) = ValD (toPat p) + (hsRhsToBody rhs) + (toDecs bnds) + + toDec i@(Hs.InstDecl _ (Just overlap) _ _) = + noTH "toDec" (fmap (const ()) overlap, i) + + -- the 'vars' bit seems to be for: instance forall a. C (T a) where ... + -- TH's own parser seems to flat-out ignore them, and honestly I can't see + -- that it's obviously wrong to do so. +#if MIN_VERSION_template_haskell(2,11,0) + toDec (Hs.InstDecl _ Nothing irule ids) = InstanceD + Nothing + (toCxt irule) + (toType irule) + (toDecs ids) +#else + toDec (Hs.InstDecl _ Nothing irule ids) = InstanceD + (toCxt irule) + (toType irule) + (toDecs ids) +#endif + + toDec (Hs.ClassDecl _ cxt h fds decls) = ClassD + (toCxt cxt) + (toName h) + (toTyVars h) + (fmap toFunDep fds) + (toDecs decls) + where + toFunDep (Hs.FunDep _ ls rs) = FunDep (fmap toName ls) (fmap toName rs) + + toDec x = todo "toDec" x + +#if MIN_VERSION_haskell_src_exts(1,18,0) +instance ToMaybeKind (Hs.ResultSig l) where + toMaybeKind (Hs.KindSig _ k) = Just $ toKind k + toMaybeKind (Hs.TyVarSig _ _) = Nothing + +instance ToMaybeKind a => ToMaybeKind (Maybe a) where + toMaybeKind Nothing = Nothing + toMaybeKind (Just a) = toMaybeKind a + +#if MIN_VERSION_template_haskell(2,11,0) +instance ToInjectivityAnn (Hs.InjectivityInfo l) where + toInjectivityAnn (Hs.InjectivityInfo _ n ns) = InjectivityAnn (toName n) (fmap toName ns) +#endif +#endif + +transAct :: Maybe (Hs.Activation l) -> Phases +transAct Nothing = AllPhases +transAct (Just (Hs.ActiveFrom _ n)) = FromPhase n +transAct (Just (Hs.ActiveUntil _ n)) = BeforePhase n + +instance ToName (Hs.DeclHead l) where + toName (Hs.DHead _ n) = toName n + toName (Hs.DHInfix _ _ n) = toName n + toName (Hs.DHParen _ h) = toName h + toName (Hs.DHApp _ h _) = toName h + +instance ToTyVars (Hs.DeclHead l) where + toTyVars (Hs.DHead _ _) = [] + toTyVars (Hs.DHParen _ h) = toTyVars h + toTyVars (Hs.DHInfix _ tvb _) = [toTyVar tvb] + toTyVars (Hs.DHApp _ h tvb) = toTyVars h ++ [toTyVar tvb] + +instance ToNames a => ToNames (Maybe a) where + toNames Nothing = [] + toNames (Just a) = toNames a + +instance ToNames (Hs.Deriving l) where + toNames (Hs.Deriving _ irules) = concatMap toNames irules +instance ToNames (Hs.InstRule l) where + toNames (Hs.IParen _ irule) = toNames irule + toNames (Hs.IRule _ _mtvbs _mcxt mihd) = toNames mihd +instance ToNames (Hs.InstHead l) where + toNames (Hs.IHCon _ n) = [toName n] + toNames (Hs.IHInfix _ _ n) = [toName n] + toNames (Hs.IHParen _ h) = toNames h + toNames (Hs.IHApp _ h _) = toNames h + +instance ToCxt (Hs.InstRule l) where + toCxt (Hs.IRule _ _ cxt _) = toCxt cxt + toCxt (Hs.IParen _ irule) = toCxt irule + +instance ToCxt (Hs.Context l) where + toCxt x = case x of + Hs.CxEmpty _ -> [] + Hs.CxSingle _ x' -> [toPred x'] + Hs.CxTuple _ xs -> fmap toPred xs + +instance ToType (Hs.InstRule l) where + toType (Hs.IRule _ _ _ h) = toType h + toType (Hs.IParen _ irule) = toType irule + +instance ToType (Hs.InstHead l) where + toType (Hs.IHCon _ qn) = toType qn + toType (Hs.IHInfix _ typ qn) = AppT (toType typ) (toType qn) + toType (Hs.IHParen _ hd) = toType hd + toType (Hs.IHApp _ hd typ) = AppT (toType hd) (toType typ) + +qualConDeclToCon :: Hs.QualConDecl l -> Con +qualConDeclToCon (Hs.QualConDecl _ Nothing Nothing cdecl) = conDeclToCon cdecl +qualConDeclToCon (Hs.QualConDecl _ ns cxt cdecl) = ForallC (toTyVars ns) + (toCxt cxt) + (conDeclToCon cdecl) + +instance ToTyVars a => ToTyVars (Maybe a) where + toTyVars Nothing = [] + toTyVars (Just a) = toTyVars a + +instance ToTyVars a => ToTyVars [a] where + toTyVars = concatMap toTyVars + +instance ToTyVars (Hs.TyVarBind l) where + toTyVars tvb = [toTyVar tvb] + +instance ToType (Hs.QName l) where + toType = ConT . toName + +conDeclToCon :: Hs.ConDecl l -> Con +conDeclToCon (Hs.ConDecl _ n tys) + = NormalC (toName n) (map toStrictType tys) +conDeclToCon (Hs.RecDecl _ n fieldDecls) + = RecC (toName n) (concatMap convField fieldDecls) + where + convField :: Hs.FieldDecl l -> [VarStrictType] + convField (Hs.FieldDecl _ ns t) = + let (strict, ty) = toStrictType t + in map (\n' -> (toName n', strict, ty)) ns + + +hsMatchesToFunD :: [Hs.Match l] -> Dec +hsMatchesToFunD [] = FunD (mkName []) [] -- errorish +hsMatchesToFunD xs@(Hs.Match _ n _ _ _ : _) = FunD (toName n) (fmap hsMatchToClause xs) + + +hsMatchToClause :: Hs.Match l -> Clause +hsMatchToClause (Hs.Match _ _ ps rhs bnds) = Clause + (fmap toPat ps) + (hsRhsToBody rhs) + (toDecs bnds) + + + +hsRhsToBody :: Hs.Rhs l -> Body +hsRhsToBody (Hs.UnGuardedRhs _ e) = NormalB (toExp e) +hsRhsToBody (Hs.GuardedRhss _ hsgrhs) = let fromGuardedB (GuardedB a) = a + in GuardedB . concat + . fmap (fromGuardedB . hsGuardedRhsToBody) + $ hsgrhs + + + +hsGuardedRhsToBody :: Hs.GuardedRhs l -> Body +hsGuardedRhsToBody (Hs.GuardedRhs _ [] e) = NormalB (toExp e) +hsGuardedRhsToBody (Hs.GuardedRhs _ [s] e) = GuardedB [(hsStmtToGuard s, toExp e)] +hsGuardedRhsToBody (Hs.GuardedRhs _ ss e) = let ss' = fmap hsStmtToGuard ss + (pgs,ngs) = unzip [(p,n) + | (PatG p) <- ss' + , n@(NormalG _) <- ss'] + e' = toExp e + patg = PatG (concat pgs) + in GuardedB $ (patg,e') : zip ngs (repeat e') + + + +hsStmtToGuard :: Hs.Stmt l -> Guard +hsStmtToGuard (Hs.Generator _ p e) = PatG [BindS (toPat p) (toExp e)] +hsStmtToGuard (Hs.Qualifier _ e) = NormalG (toExp e) +hsStmtToGuard (Hs.LetStmt _ bs) = PatG [LetS (toDecs bs)] + + +----------------------------------------------------------------------------- + +-- * ToDecs InstDecl +instance ToDecs (Hs.InstDecl l) where + toDecs (Hs.InsDecl _ decl) = toDecs decl + toDecs d = todo "toDec" d + +-- * ToDecs HsDecl HsBinds + +instance ToDecs (Hs.Decl l) where + toDecs a@(Hs.TypeSig _ ns t) + = let xs = fmap (flip SigD (fixForall $ toType t) . toName) ns + in xs + + toDecs (Hs.InfixDecl l assoc Nothing ops) = + toDecs (Hs.InfixDecl l assoc (Just 9) ops) + toDecs (Hs.InfixDecl _ assoc (Just fixity) ops) = + map (\op -> InfixD (Fixity fixity dir) (toName op)) ops + where + dir = case assoc of + Hs.AssocNone _ -> InfixN + Hs.AssocLeft _ -> InfixL + Hs.AssocRight _ -> InfixR + + toDecs a = [toDec a] + +collectVars e = case e of + VarT n -> [PlainTV n] + AppT t1 t2 -> nub $ collectVars t1 ++ collectVars t2 + ForallT ns _ t -> collectVars t \\ ns + _ -> [] + +fixForall t@(ForallT _ _ _) = t +fixForall t = case vs of + [] -> t + _ -> ForallT vs [] t + where vs = collectVars t + +instance ToDecs a => ToDecs [a] where + toDecs a = concatMap toDecs a + +----------------------------------------------------------------------------- diff --git a/doc/generated/FontHersheyComplex.png b/doc/generated/FontHersheyComplex.png new file mode 100644 Binary files /dev/null and b/doc/generated/FontHersheyComplex.png differ diff --git a/doc/generated/FontHersheyComplexSmall.png b/doc/generated/FontHersheyComplexSmall.png new file mode 100644 Binary files /dev/null and b/doc/generated/FontHersheyComplexSmall.png differ diff --git a/doc/generated/FontHersheyComplexSmall_slanted.png b/doc/generated/FontHersheyComplexSmall_slanted.png new file mode 100644 Binary files /dev/null and b/doc/generated/FontHersheyComplexSmall_slanted.png differ diff --git a/doc/generated/FontHersheyComplex_slanted.png b/doc/generated/FontHersheyComplex_slanted.png new file mode 100644 Binary files /dev/null and b/doc/generated/FontHersheyComplex_slanted.png differ diff --git a/doc/generated/FontHersheyDuplex.png b/doc/generated/FontHersheyDuplex.png new file mode 100644 Binary files /dev/null and b/doc/generated/FontHersheyDuplex.png differ diff --git a/doc/generated/FontHersheyDuplex_slanted.png b/doc/generated/FontHersheyDuplex_slanted.png new file mode 100644 Binary files /dev/null and b/doc/generated/FontHersheyDuplex_slanted.png differ diff --git a/doc/generated/FontHersheyPlain.png b/doc/generated/FontHersheyPlain.png new file mode 100644 Binary files /dev/null and b/doc/generated/FontHersheyPlain.png differ diff --git a/doc/generated/FontHersheyPlain_slanted.png b/doc/generated/FontHersheyPlain_slanted.png new file mode 100644 Binary files /dev/null and b/doc/generated/FontHersheyPlain_slanted.png differ diff --git a/doc/generated/FontHersheyScriptComplex.png b/doc/generated/FontHersheyScriptComplex.png new file mode 100644 Binary files /dev/null and b/doc/generated/FontHersheyScriptComplex.png differ diff --git a/doc/generated/FontHersheyScriptComplex_slanted.png b/doc/generated/FontHersheyScriptComplex_slanted.png new file mode 100644 Binary files /dev/null and b/doc/generated/FontHersheyScriptComplex_slanted.png differ diff --git a/doc/generated/FontHersheyScriptSimplex.png b/doc/generated/FontHersheyScriptSimplex.png new file mode 100644 Binary files /dev/null and b/doc/generated/FontHersheyScriptSimplex.png differ diff --git a/doc/generated/FontHersheyScriptSimplex_slanted.png b/doc/generated/FontHersheyScriptSimplex_slanted.png new file mode 100644 Binary files /dev/null and b/doc/generated/FontHersheyScriptSimplex_slanted.png differ diff --git a/doc/generated/FontHersheySimplex.png b/doc/generated/FontHersheySimplex.png new file mode 100644 Binary files /dev/null and b/doc/generated/FontHersheySimplex.png differ diff --git a/doc/generated/FontHersheySimplex_slanted.png b/doc/generated/FontHersheySimplex_slanted.png new file mode 100644 Binary files /dev/null and b/doc/generated/FontHersheySimplex_slanted.png differ diff --git a/doc/generated/FontHersheyTriplex.png b/doc/generated/FontHersheyTriplex.png new file mode 100644 Binary files /dev/null and b/doc/generated/FontHersheyTriplex.png differ diff --git a/doc/generated/FontHersheyTriplex_slanted.png b/doc/generated/FontHersheyTriplex_slanted.png new file mode 100644 Binary files /dev/null and b/doc/generated/FontHersheyTriplex_slanted.png differ diff --git a/doc/generated/LineType_4.png b/doc/generated/LineType_4.png new file mode 100644 Binary files /dev/null and b/doc/generated/LineType_4.png differ diff --git a/doc/generated/LineType_8.png b/doc/generated/LineType_8.png new file mode 100644 Binary files /dev/null and b/doc/generated/LineType_8.png differ diff --git a/doc/generated/LineType_AA.png b/doc/generated/LineType_AA.png new file mode 100644 Binary files /dev/null and b/doc/generated/LineType_AA.png differ diff --git a/doc/generated/bikes_512x341.png b/doc/generated/bikes_512x341.png new file mode 100644 Binary files /dev/null and b/doc/generated/bikes_512x341.png differ diff --git a/doc/generated/birds_512x341.png b/doc/generated/birds_512x341.png new file mode 100644 Binary files /dev/null and b/doc/generated/birds_512x341.png differ diff --git a/doc/generated/examples/arrowedLineImg.png b/doc/generated/examples/arrowedLineImg.png new file mode 100644 Binary files /dev/null and b/doc/generated/examples/arrowedLineImg.png differ diff --git a/doc/generated/examples/bfMatcherImg.png b/doc/generated/examples/bfMatcherImg.png new file mode 100644 Binary files /dev/null and b/doc/generated/examples/bfMatcherImg.png differ diff --git a/doc/generated/examples/bitwiseAndImg.png b/doc/generated/examples/bitwiseAndImg.png new file mode 100644 Binary files /dev/null and b/doc/generated/examples/bitwiseAndImg.png differ diff --git a/doc/generated/examples/bitwiseNotImg.png b/doc/generated/examples/bitwiseNotImg.png new file mode 100644 Binary files /dev/null and b/doc/generated/examples/bitwiseNotImg.png differ diff --git a/doc/generated/examples/bitwiseOrImg.png b/doc/generated/examples/bitwiseOrImg.png new file mode 100644 Binary files /dev/null and b/doc/generated/examples/bitwiseOrImg.png differ diff --git a/doc/generated/examples/bitwiseXorImg.png b/doc/generated/examples/bitwiseXorImg.png new file mode 100644 Binary files /dev/null and b/doc/generated/examples/bitwiseXorImg.png differ diff --git a/doc/generated/examples/boxBlurImg.png b/doc/generated/examples/boxBlurImg.png new file mode 100644 Binary files /dev/null and b/doc/generated/examples/boxBlurImg.png differ diff --git a/doc/generated/examples/cannyImg.png b/doc/generated/examples/cannyImg.png new file mode 100644 Binary files /dev/null and b/doc/generated/examples/cannyImg.png differ diff --git a/doc/generated/examples/cascadeClassifierArnold.png b/doc/generated/examples/cascadeClassifierArnold.png new file mode 100644 Binary files /dev/null and b/doc/generated/examples/cascadeClassifierArnold.png differ diff --git a/doc/generated/examples/circleImg.png b/doc/generated/examples/circleImg.png new file mode 100644 Binary files /dev/null and b/doc/generated/examples/circleImg.png differ diff --git a/doc/generated/examples/colorMapAutumImg.png b/doc/generated/examples/colorMapAutumImg.png new file mode 100644 Binary files /dev/null and b/doc/generated/examples/colorMapAutumImg.png differ diff --git a/doc/generated/examples/colorMapBoneImg.png b/doc/generated/examples/colorMapBoneImg.png new file mode 100644 Binary files /dev/null and b/doc/generated/examples/colorMapBoneImg.png differ diff --git a/doc/generated/examples/colorMapCoolImg.png b/doc/generated/examples/colorMapCoolImg.png new file mode 100644 Binary files /dev/null and b/doc/generated/examples/colorMapCoolImg.png differ diff --git a/doc/generated/examples/colorMapHotImg.png b/doc/generated/examples/colorMapHotImg.png new file mode 100644 Binary files /dev/null and b/doc/generated/examples/colorMapHotImg.png differ diff --git a/doc/generated/examples/colorMapHsvImg.png b/doc/generated/examples/colorMapHsvImg.png new file mode 100644 Binary files /dev/null and b/doc/generated/examples/colorMapHsvImg.png differ diff --git a/doc/generated/examples/colorMapJetImg.png b/doc/generated/examples/colorMapJetImg.png new file mode 100644 Binary files /dev/null and b/doc/generated/examples/colorMapJetImg.png differ diff --git a/doc/generated/examples/colorMapOceanImg.png b/doc/generated/examples/colorMapOceanImg.png new file mode 100644 Binary files /dev/null and b/doc/generated/examples/colorMapOceanImg.png differ diff --git a/doc/generated/examples/colorMapParulaImg.png b/doc/generated/examples/colorMapParulaImg.png new file mode 100644 Binary files /dev/null and b/doc/generated/examples/colorMapParulaImg.png differ diff --git a/doc/generated/examples/colorMapPinkImg.png b/doc/generated/examples/colorMapPinkImg.png new file mode 100644 Binary files /dev/null and b/doc/generated/examples/colorMapPinkImg.png differ diff --git a/doc/generated/examples/colorMapRainbowImg.png b/doc/generated/examples/colorMapRainbowImg.png new file mode 100644 Binary files /dev/null and b/doc/generated/examples/colorMapRainbowImg.png differ diff --git a/doc/generated/examples/colorMapSpringImg.png b/doc/generated/examples/colorMapSpringImg.png new file mode 100644 Binary files /dev/null and b/doc/generated/examples/colorMapSpringImg.png differ diff --git a/doc/generated/examples/colorMapSummerImg.png b/doc/generated/examples/colorMapSummerImg.png new file mode 100644 Binary files /dev/null and b/doc/generated/examples/colorMapSummerImg.png differ diff --git a/doc/generated/examples/colorMapWinterImg.png b/doc/generated/examples/colorMapWinterImg.png new file mode 100644 Binary files /dev/null and b/doc/generated/examples/colorMapWinterImg.png differ diff --git a/doc/generated/examples/cvtColorImg.png b/doc/generated/examples/cvtColorImg.png new file mode 100644 Binary files /dev/null and b/doc/generated/examples/cvtColorImg.png differ diff --git a/doc/generated/examples/dctDenoisingImg.png b/doc/generated/examples/dctDenoisingImg.png new file mode 100644 Binary files /dev/null and b/doc/generated/examples/dctDenoisingImg.png differ diff --git a/doc/generated/examples/decolorImg.png b/doc/generated/examples/decolorImg.png new file mode 100644 Binary files /dev/null and b/doc/generated/examples/decolorImg.png differ diff --git a/doc/generated/examples/denoise_TVL1Img.png b/doc/generated/examples/denoise_TVL1Img.png new file mode 100644 Binary files /dev/null and b/doc/generated/examples/denoise_TVL1Img.png differ diff --git a/doc/generated/examples/dilateImg.png b/doc/generated/examples/dilateImg.png new file mode 100644 Binary files /dev/null and b/doc/generated/examples/dilateImg.png differ diff --git a/doc/generated/examples/drawChArUcoBoardImg.png b/doc/generated/examples/drawChArUcoBoardImg.png new file mode 100644 Binary files /dev/null and b/doc/generated/examples/drawChArUcoBoardImg.png differ diff --git a/doc/generated/examples/ellipseImg.png b/doc/generated/examples/ellipseImg.png new file mode 100644 Binary files /dev/null and b/doc/generated/examples/ellipseImg.png differ diff --git a/doc/generated/examples/erodeImg.png b/doc/generated/examples/erodeImg.png new file mode 100644 Binary files /dev/null and b/doc/generated/examples/erodeImg.png differ diff --git a/doc/generated/examples/fastNlMeansDenoisingColoredImg.png b/doc/generated/examples/fastNlMeansDenoisingColoredImg.png new file mode 100644 Binary files /dev/null and b/doc/generated/examples/fastNlMeansDenoisingColoredImg.png differ diff --git a/doc/generated/examples/fastNlMeansDenoisingColoredMultiImg.png b/doc/generated/examples/fastNlMeansDenoisingColoredMultiImg.png new file mode 100644 Binary files /dev/null and b/doc/generated/examples/fastNlMeansDenoisingColoredMultiImg.png differ diff --git a/doc/generated/examples/fbMatcherImg.png b/doc/generated/examples/fbMatcherImg.png new file mode 100644 Binary files /dev/null and b/doc/generated/examples/fbMatcherImg.png differ diff --git a/doc/generated/examples/fillConvexPolyImg.png b/doc/generated/examples/fillConvexPolyImg.png new file mode 100644 Binary files /dev/null and b/doc/generated/examples/fillConvexPolyImg.png differ diff --git a/doc/generated/examples/fillPolyImg.png b/doc/generated/examples/fillPolyImg.png new file mode 100644 Binary files /dev/null and b/doc/generated/examples/fillPolyImg.png differ diff --git a/doc/generated/examples/filter2DImg.png b/doc/generated/examples/filter2DImg.png new file mode 100644 Binary files /dev/null and b/doc/generated/examples/filter2DImg.png differ diff --git a/doc/generated/examples/floodFillImg.png b/doc/generated/examples/floodFillImg.png new file mode 100644 Binary files /dev/null and b/doc/generated/examples/floodFillImg.png differ diff --git a/doc/generated/examples/flowerContours.png b/doc/generated/examples/flowerContours.png new file mode 100644 Binary files /dev/null and b/doc/generated/examples/flowerContours.png differ diff --git a/doc/generated/examples/fromImageImg.png b/doc/generated/examples/fromImageImg.png new file mode 100644 Binary files /dev/null and b/doc/generated/examples/fromImageImg.png differ diff --git a/doc/generated/examples/goodFeaturesToTrackTraces.png b/doc/generated/examples/goodFeaturesToTrackTraces.png new file mode 100644 Binary files /dev/null and b/doc/generated/examples/goodFeaturesToTrackTraces.png differ diff --git a/doc/generated/examples/grabCutBird.png b/doc/generated/examples/grabCutBird.png new file mode 100644 Binary files /dev/null and b/doc/generated/examples/grabCutBird.png differ diff --git a/doc/generated/examples/grayscaleImg.png b/doc/generated/examples/grayscaleImg.png new file mode 100644 Binary files /dev/null and b/doc/generated/examples/grayscaleImg.png differ diff --git a/doc/generated/examples/grayworldWBImg.png b/doc/generated/examples/grayworldWBImg.png new file mode 100644 # file too large to diff: doc/generated/examples/grayworldWBImg.png diff --git a/doc/generated/examples/houghCircleTraces.png b/doc/generated/examples/houghCircleTraces.png new file mode 100644 Binary files /dev/null and b/doc/generated/examples/houghCircleTraces.png differ diff --git a/doc/generated/examples/houghLinesPTraces.png b/doc/generated/examples/houghLinesPTraces.png new file mode 100644 Binary files /dev/null and b/doc/generated/examples/houghLinesPTraces.png differ diff --git a/doc/generated/examples/inpaintImg.png b/doc/generated/examples/inpaintImg.png new file mode 100644 Binary files /dev/null and b/doc/generated/examples/inpaintImg.png differ diff --git a/doc/generated/examples/laplacianImg.png b/doc/generated/examples/laplacianImg.png new file mode 100644 Binary files /dev/null and b/doc/generated/examples/laplacianImg.png differ diff --git a/doc/generated/examples/lineImg.png b/doc/generated/examples/lineImg.png new file mode 100644 Binary files /dev/null and b/doc/generated/examples/lineImg.png differ diff --git a/doc/generated/examples/markerImg.png b/doc/generated/examples/markerImg.png new file mode 100644 Binary files /dev/null and b/doc/generated/examples/markerImg.png differ diff --git a/doc/generated/examples/matAbsDiffImg.png b/doc/generated/examples/matAbsDiffImg.png new file mode 100644 Binary files /dev/null and b/doc/generated/examples/matAbsDiffImg.png differ diff --git a/doc/generated/examples/matAddImg.png b/doc/generated/examples/matAddImg.png new file mode 100644 Binary files /dev/null and b/doc/generated/examples/matAddImg.png differ diff --git a/doc/generated/examples/matAddWeightedImg.png b/doc/generated/examples/matAddWeightedImg.png new file mode 100644 Binary files /dev/null and b/doc/generated/examples/matAddWeightedImg.png differ diff --git a/doc/generated/examples/matFlipImg.png b/doc/generated/examples/matFlipImg.png new file mode 100644 Binary files /dev/null and b/doc/generated/examples/matFlipImg.png differ diff --git a/doc/generated/examples/matFromFuncImg.png b/doc/generated/examples/matFromFuncImg.png new file mode 100644 Binary files /dev/null and b/doc/generated/examples/matFromFuncImg.png differ diff --git a/doc/generated/examples/matSplitImg.png b/doc/generated/examples/matSplitImg.png new file mode 100644 Binary files /dev/null and b/doc/generated/examples/matSplitImg.png differ diff --git a/doc/generated/examples/matSubRectImg.png b/doc/generated/examples/matSubRectImg.png new file mode 100644 Binary files /dev/null and b/doc/generated/examples/matSubRectImg.png differ diff --git a/doc/generated/examples/matSubtractImg.png b/doc/generated/examples/matSubtractImg.png new file mode 100644 Binary files /dev/null and b/doc/generated/examples/matSubtractImg.png differ diff --git a/doc/generated/examples/matSumImg.png b/doc/generated/examples/matSumImg.png new file mode 100644 Binary files /dev/null and b/doc/generated/examples/matSumImg.png differ diff --git a/doc/generated/examples/matTransposeImg.png b/doc/generated/examples/matTransposeImg.png new file mode 100644 Binary files /dev/null and b/doc/generated/examples/matTransposeImg.png differ diff --git a/doc/generated/examples/medianBlurImg.png b/doc/generated/examples/medianBlurImg.png new file mode 100644 Binary files /dev/null and b/doc/generated/examples/medianBlurImg.png differ diff --git a/doc/generated/examples/morphCrossImg.png b/doc/generated/examples/morphCrossImg.png new file mode 100644 Binary files /dev/null and b/doc/generated/examples/morphCrossImg.png differ diff --git a/doc/generated/examples/morphEllipseImg.png b/doc/generated/examples/morphEllipseImg.png new file mode 100644 Binary files /dev/null and b/doc/generated/examples/morphEllipseImg.png differ diff --git a/doc/generated/examples/morphRectImg.png b/doc/generated/examples/morphRectImg.png new file mode 100644 Binary files /dev/null and b/doc/generated/examples/morphRectImg.png differ diff --git a/doc/generated/examples/orbDetectAndComputeImg.png b/doc/generated/examples/orbDetectAndComputeImg.png new file mode 100644 Binary files /dev/null and b/doc/generated/examples/orbDetectAndComputeImg.png differ diff --git a/doc/generated/examples/polylinesImg.png b/doc/generated/examples/polylinesImg.png new file mode 100644 Binary files /dev/null and b/doc/generated/examples/polylinesImg.png differ diff --git a/doc/generated/examples/putTextImg.png b/doc/generated/examples/putTextImg.png new file mode 100644 Binary files /dev/null and b/doc/generated/examples/putTextImg.png differ diff --git a/doc/generated/examples/rectangleImg.png b/doc/generated/examples/rectangleImg.png new file mode 100644 Binary files /dev/null and b/doc/generated/examples/rectangleImg.png differ diff --git a/doc/generated/examples/remapImg.png b/doc/generated/examples/remapImg.png new file mode 100644 Binary files /dev/null and b/doc/generated/examples/remapImg.png differ diff --git a/doc/generated/examples/resizeInterAreaImg.png b/doc/generated/examples/resizeInterAreaImg.png new file mode 100644 Binary files /dev/null and b/doc/generated/examples/resizeInterAreaImg.png differ diff --git a/doc/generated/examples/surfDetectAndComputeImg.png b/doc/generated/examples/surfDetectAndComputeImg.png new file mode 100644 Binary files /dev/null and b/doc/generated/examples/surfDetectAndComputeImg.png differ diff --git a/doc/generated/examples/threshBinaryBirds.png b/doc/generated/examples/threshBinaryBirds.png new file mode 100644 Binary files /dev/null and b/doc/generated/examples/threshBinaryBirds.png differ diff --git a/doc/generated/examples/threshBinaryInvBirds.png b/doc/generated/examples/threshBinaryInvBirds.png new file mode 100644 Binary files /dev/null and b/doc/generated/examples/threshBinaryInvBirds.png differ diff --git a/doc/generated/examples/threshToZeroBirds.png b/doc/generated/examples/threshToZeroBirds.png new file mode 100644 Binary files /dev/null and b/doc/generated/examples/threshToZeroBirds.png differ diff --git a/doc/generated/examples/threshToZeroInvBirds.png b/doc/generated/examples/threshToZeroInvBirds.png new file mode 100644 Binary files /dev/null and b/doc/generated/examples/threshToZeroInvBirds.png differ diff --git a/doc/generated/examples/threshTruncateBirds.png b/doc/generated/examples/threshTruncateBirds.png new file mode 100644 Binary files /dev/null and b/doc/generated/examples/threshTruncateBirds.png differ diff --git a/doc/generated/examples/toImageImg.png b/doc/generated/examples/toImageImg.png new file mode 100644 Binary files /dev/null and b/doc/generated/examples/toImageImg.png differ diff --git a/doc/generated/examples/undistortImg.png b/doc/generated/examples/undistortImg.png new file mode 100644 Binary files /dev/null and b/doc/generated/examples/undistortImg.png differ diff --git a/doc/generated/examples/vennCircleAImg.png b/doc/generated/examples/vennCircleAImg.png new file mode 100644 Binary files /dev/null and b/doc/generated/examples/vennCircleAImg.png differ diff --git a/doc/generated/examples/vennCircleBImg.png b/doc/generated/examples/vennCircleBImg.png new file mode 100644 Binary files /dev/null and b/doc/generated/examples/vennCircleBImg.png differ diff --git a/doc/generated/examples/warpAffineImg.png b/doc/generated/examples/warpAffineImg.png new file mode 100644 Binary files /dev/null and b/doc/generated/examples/warpAffineImg.png differ diff --git a/doc/generated/examples/warpAffineInvImg.png b/doc/generated/examples/warpAffineInvImg.png new file mode 100644 Binary files /dev/null and b/doc/generated/examples/warpAffineInvImg.png differ diff --git a/doc/generated/flower_512x341.png b/doc/generated/flower_512x341.png new file mode 100644 Binary files /dev/null and b/doc/generated/flower_512x341.png differ diff --git a/doc/generated/sailboat_512x341.png b/doc/generated/sailboat_512x341.png new file mode 100644 Binary files /dev/null and b/doc/generated/sailboat_512x341.png differ diff --git a/doc/images.hs b/doc/images.hs new file mode 100644 --- /dev/null +++ b/doc/images.hs @@ -0,0 +1,270 @@ +{-# language TemplateHaskell #-} +{-# language OverloadedStrings #-} +{-# language FlexibleContexts #-} +{-# language CPP #-} + +module Main where + +import "base" Data.Functor ( void ) +import "base" Data.Foldable ( forM_ ) +import "base" Data.Int +import "base" Data.Monoid ( (<>) ) +import "base" Data.Proxy +import "base" Data.Traversable +import "base" Data.Word +import "base" Foreign.C.Types ( CFloat ) +import "base" GHC.TypeLits +import "base" System.IO.Unsafe ( unsafePerformIO ) +import "data-default" Data.Default +import qualified "bytestring" Data.ByteString as B +import qualified "JuicyPixels" Codec.Picture +import qualified "linear" Linear.Metric as Linear ( norm ) +import "linear" Linear ( M33 ) +import "linear" Linear.Vector ( (^+^), (^-^) ) +import "linear" Linear.V2 ( V2(..) ) +import "linear" Linear.V3 ( V3(..) ) +import "linear" Linear.V4 ( V4(..) ) +import "opencv" OpenCV +import qualified "opencv" OpenCV.Juicy +import "opencv" OpenCV.Unsafe +#ifdef HAVE_OPENCV_EXTRA +import "opencv-extra" OpenCV.Extra +#endif +import "primitive" Control.Monad.Primitive ( PrimMonad, PrimState ) +import qualified "text" Data.Text as T +import qualified "vector" Data.Vector as V +import "transformers" Control.Monad.Trans.Class ( lift ) + +import "this" ExampleExtractor + +-------------------------------------------------------------------------------- + +transparent, white, black, blue, green, red :: Scalar +transparent = toScalar (V4 255 255 255 0 :: V4 Double) +white = toScalar (V4 255 255 255 255 :: V4 Double) +black = toScalar (V4 0 0 0 255 :: V4 Double) +blue = toScalar (V4 255 0 0 255 :: V4 Double) +green = toScalar (V4 0 255 0 255 :: V4 Double) +red = toScalar (V4 0 0 255 255 :: V4 Double) + +type Birds_768x512 = Mat (ShapeT [512, 768]) ('S 3) ('S Word8) +type Flower_768x512 = Mat (ShapeT [512, 768]) ('S 3) ('S Word8) +type Sailboat_768x512 = Mat (ShapeT [512, 768]) ('S 3) ('S Word8) +type Bikes_768x512 = Mat (ShapeT [512, 768]) ('S 3) ('S Word8) +type Birds_512x341 = Mat (ShapeT [341, 512]) ('S 3) ('S Word8) +type Flower_512x341 = Mat (ShapeT [341, 512]) ('S 3) ('S Word8) +type Sailboat_512x341 = Mat (ShapeT [341, 512]) ('S 3) ('S Word8) +type Bikes_512x341 = Mat (ShapeT [341, 512]) ('S 3) ('S Word8) +type Frog = Mat (ShapeT [390, 500]) ('S 3) ('S Word8) +type Lambda = Mat (ShapeT [256, 256]) ('S 1) ('S Word8) +type Circles_1000x625 = Mat (ShapeT [625, 1000]) ('S 3) ('S Word8) +type Building_868x600 = Mat (ShapeT [600, 868]) ('S 3) ('S Word8) +type DamageMask = Mat (ShapeT [341, 512]) ('S 1) ('S Word8) +type Lenna_512x512 = Mat (ShapeT [512, 512]) ('S 3) ('S Word8) +type Arnold = Mat (ShapeT [3504, 2336]) ('S 3) ('S Word8) +type Arnold_small = Mat (ShapeT [ 900, 600]) ('S 3) ('S Word8) + +birds_768x512 :: Birds_768x512 +birds_768x512 = exceptError $ coerceMat $ unsafePerformIO $ + imdecode ImreadUnchanged <$> B.readFile "data/kodim23.png" + +flower_768x512 :: Flower_768x512 +flower_768x512 = + exceptError $ coerceMat $ unsafePerformIO $ + imdecode ImreadUnchanged <$> B.readFile "data/kodim07.png" + +sailboat_768x512 :: Sailboat_768x512 +sailboat_768x512 = + exceptError $ coerceMat $ unsafePerformIO $ + imdecode ImreadUnchanged <$> B.readFile "data/kodim06.png" + +bikes_768x512 :: Sailboat_768x512 +bikes_768x512 = + exceptError $ coerceMat $ unsafePerformIO $ + imdecode ImreadUnchanged <$> B.readFile "data/kodim05.png" + +damageMask :: DamageMask +damageMask = + exceptError $ coerceMat $ unsafePerformIO $ + imdecode ImreadUnchanged <$> B.readFile "data/damage_mask.png" + +smallerKodakImg + :: Mat (ShapeT [512, 768]) ('S 3) ('S Word8) + -> Mat (ShapeT [341, 512]) ('S 3) ('S Word8) +smallerKodakImg img = + exceptError $ coerceMat =<< + resize (ResizeAbs $ toSize (V2 512 341 :: V2 Int32)) + InterArea + img + +birds_512x341 :: Birds_512x341 +birds_512x341 = smallerKodakImg birds_768x512 + +flower_512x341 :: Flower_512x341 +flower_512x341 = smallerKodakImg flower_768x512 + +sailboat_512x341 :: Flower_512x341 +sailboat_512x341 = smallerKodakImg sailboat_768x512 + +bikes_512x341 :: Flower_512x341 +bikes_512x341 = smallerKodakImg bikes_768x512 + +frog :: Frog +frog = + exceptError $ coerceMat $ unsafePerformIO $ + imdecode ImreadUnchanged <$> B.readFile "data/kikker.jpg" + +lambda :: Lambda +lambda = + exceptError $ coerceMat $ unsafePerformIO $ + imdecode ImreadGrayscale <$> B.readFile "data/lambda.png" + +circles_1000x625 :: Circles_1000x625 +circles_1000x625 = + exceptError $ coerceMat $ unsafePerformIO $ + imdecode ImreadUnchanged <$> B.readFile "data/circles.png" + +building_868x600 :: Building_868x600 +building_868x600 = + exceptError $ coerceMat $ unsafePerformIO $ + imdecode ImreadUnchanged <$> B.readFile "data/building.jpg" + +lenna_512x512 :: Lenna_512x512 +lenna_512x512 = + exceptError $ coerceMat $ unsafePerformIO $ + imdecode ImreadUnchanged <$> B.readFile "data/Lenna.png" + +arnold :: Arnold +arnold = + exceptError $ coerceMat $ unsafePerformIO $ + imdecode ImreadUnchanged <$> B.readFile "data/arnold-schwarzenegger.jpg" + +arnold_small :: Arnold_small +arnold_small = + exceptError $ coerceMat =<< + resize (ResizeAbs $ toSize (V2 600 900 :: V2 Int32)) + InterArea + arnold + +-------------------------------------------------------------------------------- + +type CarOverhead = Animation (ShapeT [240, 320]) ('S 3) ('S Word8) + +carOverhead :: CarOverhead +carOverhead = unsafePerformIO $ loadAnimation 4 "data/car-overhead-3.mp4" + +-------------------------------------------------------------------------------- + +loadAnimation + :: (ToNatDS (Proxy h), ToNatDS (Proxy w)) + => Int + -> FilePath + -> IO (Animation ('S [h, w]) ('S 3) ('S Word8)) +loadAnimation delay fp = do + cap <- newVideoCapture + exceptErrorIO $ videoCaptureOpen cap (VideoFileSource fp Nothing) + frames <- grabFrames cap [] + exceptErrorIO $ videoCaptureRelease cap + pure $ map (delay, ) frames + where + grabFrames cap frames = do + ok <- videoCaptureGrab cap + if ok + then do + mbFrameRaw <- videoCaptureRetrieve cap + case mbFrameRaw of + Nothing -> pure $ reverse frames + Just frameRaw -> do + frame <- exceptErrorIO $ pureExcept $ coerceMat frameRaw + grabFrames cap (frame : frames) + else pure $ reverse frames + +-------------------------------------------------------------------------------- + +-- We use some padding around the small image in which we draw the +-- lines. This is because antialiasing doesn't seem to work near the +-- edges of an image. +lineTypeImg + :: forall (h :: Nat) (w :: Nat) (p :: Nat) + . ( h ~ 5 + , w ~ (h * 3) + , p ~ 20 + ) + => LineType + -> Mat ('S ['D, 'D]) ('S 4) ('S Word8) +lineTypeImg lineType = exceptError $ do + img <- withMatM (h + 2 * p ::: w + 2 * p ::: Z) + (Proxy :: Proxy 4) + (Proxy :: Proxy Word8) + transparent $ \imgM -> do + lift $ line imgM (pure p + V2 0 h) (pure p + V2 w 0) black 1 lineType 0 + resize (ResizeRel $ pure zoom) InterNearest + =<< matSubRect img (toRect $ HRect (pure p) (V2 w h)) + where + w, h, p :: Int32 + w = fromInteger $ natVal (Proxy :: Proxy w) + h = fromInteger $ natVal (Proxy :: Proxy h) + p = fromInteger $ natVal (Proxy :: Proxy p) + zoom = 8 + +fontImg + :: Font + -> Mat ('S ['D, 'D]) ('S 4) ('S Word8) +fontImg font = exceptError $ + withMatM (th * 3 ::: tw ::: Z) + (Proxy :: Proxy 4) + (Proxy :: Proxy Word8) + transparent $ \imgM -> do + putText + imgM + txt + (V2 0 (th * 2 - baseLine) :: V2 Int32) + font + black + thickness + LineType_AA False + where + txt = "The quick brown fox jumps over the lazy dog" + (size2i, baseLine) = getTextSize txt font thickness + tw, th :: Int32 + V2 tw th = fromSize size2i + thickness = 1 + +vennCircleA + :: (PrimMonad m, ToScalar color) + => Mut (Mat ('S [height, width]) channels depth) (PrimState m) + -> color + -> Int32 + -> m () +vennCircleA imgM color thickness = + circle imgM (V2 100 100 :: V2 Int32) 90 color thickness LineType_AA 0 + +vennCircleB + :: (PrimMonad m, ToScalar color) + => Mut (Mat ('S [height, width]) channels depth) (PrimState m) + -> color + -> Int32 + -> m () +vennCircleB imgM color thickness = + circle imgM (V2 220 100 :: V2 Int32) 90 color thickness LineType_AA 0 + +-------------------------------------------------------------------------------- + +extractExampleImages "src" + +-------------------------------------------------------------------------------- + +main :: IO () +main = do + renderExampleImages + renderImage "birds_512x341.png" birds_512x341 + renderImage "flower_512x341.png" flower_512x341 + renderImage "sailboat_512x341.png" sailboat_512x341 + renderImage "bikes_512x341.png" bikes_512x341 + forM_ [minBound .. maxBound] $ \lineType -> + renderImage (show lineType <> ".png") (lineTypeImg lineType) + forM_ [minBound .. maxBound] $ \fontFace -> do + renderImage (show fontFace <> ".png") (fontImg $ Font fontFace NotSlanted 1) + renderImage (show fontFace <> "_slanted.png") (fontImg $ Font fontFace Slanted 1) + +-------------------------------------------------------------------------------- diff --git a/include/aruco.hpp b/include/aruco.hpp new file mode 100644 --- /dev/null +++ b/include/aruco.hpp @@ -0,0 +1,19 @@ +#ifndef __HASKELL_OPENCV_ARUCO_H__ +#define __HASKELL_OPENCV_ARUCO_H__ + +#include +#include + +namespace cv { + typedef Matx Matx51f; + typedef Matx Matx51d; +} + +typedef std::vector< std::vector > VectorVectorPoint2f; +typedef std::vector< int > VectorInt; +typedef std::vector< cv::Mat > VectorMat; +typedef cv::Ptr< cv::aruco::Dictionary > Ptr_Dictionary; +typedef cv::Ptr< cv::aruco::CharucoBoard > Ptr_CharucoBoard; +typedef cv::Ptr< cv::aruco::Board > Board; + +#endif /* __HASKELL_OPENCV_ARUCO_H__ */ diff --git a/include/bgsegm.hpp b/include/bgsegm.hpp new file mode 100644 --- /dev/null +++ b/include/bgsegm.hpp @@ -0,0 +1,7 @@ +#ifndef __HASKELL_OPENCV_BGSEGM_H__ +#define __HASKELL_OPENCV_BGSEGM_H__ + +typedef cv::Ptr Ptr_BackgroundSubtractorGMG; +typedef cv::Ptr Ptr_BackgroundSubtractorMOG; + +#endif /* __HASKELL_OPENCV_BGSEGM_H__ */ diff --git a/include/tracking.hpp b/include/tracking.hpp new file mode 100644 --- /dev/null +++ b/include/tracking.hpp @@ -0,0 +1,9 @@ +#ifndef __HASKELL_OPENCV_TRACKING_H__ +#define __HASKELL_OPENCV_TRACKING_H__ + +typedef cv::Ptr Ptr_Tracker; +typedef cv::Ptr Ptr_TrackerFeature; +typedef cv::Ptr Ptr_MultiTracker; +typedef cv::Ptr Ptr_MultiTrackerAlt; + +#endif /* __HASKELL_OPENCV_TRACKING_H__ */ diff --git a/include/white-ballance.hpp b/include/white-ballance.hpp new file mode 100644 --- /dev/null +++ b/include/white-ballance.hpp @@ -0,0 +1,8 @@ +#ifndef __HASKELL_OPENCV_WHITE_BALLANCE_H__ +#define __HASKELL_OPENCV_WHITE_BALLANCE_H__ + +typedef cv::Ptr Ptr_GrayworldWB; +typedef cv::Ptr Ptr_LearningBasedWB; +typedef cv::Ptr Ptr_SimpleWB; + +#endif /* __HASKELL_OPENCV_WHITE_BALLANCE_H__ */ diff --git a/include/xfeatures/surf.hpp b/include/xfeatures/surf.hpp new file mode 100644 --- /dev/null +++ b/include/xfeatures/surf.hpp @@ -0,0 +1,21 @@ +#ifndef __THEA_XFEATURES_SURF_H__ +#define __THEA_XFEATURES_SURF_H__ + +#include "opencv2/xfeatures2d.hpp" + +/* +This file defines some SURF related names that are used in + + src/OpenCV/XFeatures2d.hsc. + +The reason we need these names is that we can't directly reference their +definitions because that would result in invalid syntax in either hsc2hs and +inline-c. +*/ + +// TODO #define HARRIS_SCORE cv::ORB::HARRIS_SCORE +// TODO #define FAST_SCORE cv::ORB::FAST_SCORE + +typedef cv::Ptr Ptr_SURF; + +#endif /* __THEA_XFEATURES_SURF_H__ */ diff --git a/opencv-extra.cabal b/opencv-extra.cabal new file mode 100644 --- /dev/null +++ b/opencv-extra.cabal @@ -0,0 +1,131 @@ +name: opencv-extra +version: 0.0.0.0 +homepage: https://github.com/LumiGuide/haskell-opencv +bug-reports: https://github.com/LumiGuide/haskell-opencv/issues +license: BSD3 +license-file: LICENSE +author: Roel van Dijk , Bas van Dijk +maintainer: Roel van Dijk , Bas van Dijk +build-type: Custom +cabal-version: >=1.23 +category: AI, Graphics +synopsis: Haskell binding to OpenCV-3.x extra modules + +extra-doc-files: + doc/generated/*.png + doc/generated/examples/*.png + +flag internal-documentation + description: Enables documentation generation for internal modules. + default: False + manual: True + +custom-setup + setup-depends: base, Cabal + +library + hs-source-dirs: src + include-dirs: include + install-includes: + aruco.hpp + bgsegm.hpp + tracking.hpp + white-ballance.hpp + xfeatures/surf.hpp + + c-sources: + src/OpenCV/Extra/ArUco.cpp + src/OpenCV/Extra/Bgsegm.cpp + src/OpenCV/Extra/Tracking.cpp + src/OpenCV/Extra/XPhoto.cpp + src/OpenCV/Extra/XPhoto/WhiteBalancer.cpp + src/OpenCV/Extra/XFeatures2d.cpp + + cc-options: -Wall -std=c++11 + ghc-options: -Wall -fwarn-incomplete-patterns -funbox-strict-fields -O2 + if flag(internal-documentation) + cpp-options: -DENABLE_INTERNAL_DOCUMENTATION + + build-depends: + base >= 4.8 && <5 + , bindings-DSL >= 1.0.23 + , bytestring >= 0.10.6 + , containers >= 0.5.6.2 + , inline-c >= 0.5.5.5 + , inline-c-cpp >= 0.1 + , linear >= 1.20.4 + , opencv >= 0.0.0.0 + , primitive >= 0.6.1 + , template-haskell >= 2.10 + , transformers >= 0.4.2 + , vector >= 0.11 + + exposed-modules: + OpenCV.Extra + OpenCV.Extra.ArUco + OpenCV.Extra.Bgsegm + OpenCV.Extra.XFeatures2d + OpenCV.Extra.Tracking + OpenCV.Extra.XPhoto + OpenCV.Extra.XPhoto.WhiteBalancer + + OpenCV.Extra.Internal.C.Inline + OpenCV.Extra.Internal.C.Types + + default-extensions: + BangPatterns + DataKinds + FlexibleContexts + FlexibleInstances + LambdaCase + OverloadedStrings + PackageImports + PolyKinds + ScopedTypeVariables + TupleSections + TypeFamilies + TypeOperators + + default-language: Haskell2010 + pkgconfig-depends: opencv + extra-libraries: stdc++ + +test-suite doc-images-opencv-extra + type: exitcode-stdio-1.0 + hs-source-dirs: doc + main-is: images.hs + other-modules: + ExampleExtractor + Language.Haskell.Meta.Syntax.Translate + default-language: Haskell2010 + ghc-options: -Wall -fwarn-incomplete-patterns -threaded -funbox-strict-fields -O2 -rtsopts + cpp-options: -DHAVE_OPENCV_EXTRA + build-depends: + base >= 4.8 && < 5 + , bytestring >= 0.10.6 + , containers >= 0.5.6.2 + , data-default >= 0.7.1.1 + , directory >= 1.2.2 + , Glob >= 0.7.5 + , haskell-src-exts >= 1.18.2 + , JuicyPixels >= 3.2.8.1 + , linear >= 1.20.4 + , opencv + , opencv-extra + , primitive >= 0.6.1 + , template-haskell >= 2.10 + , text >= 1.2.2.1 + , transformers >= 0.4.2 + , vector >= 0.11 + + default-extensions: + BangPatterns + DataKinds + LambdaCase + OverloadedStrings + PackageImports + PolyKinds + ScopedTypeVariables + TupleSections + TypeFamilies + TypeOperators diff --git a/src/OpenCV/Extra.hs b/src/OpenCV/Extra.hs new file mode 100644 --- /dev/null +++ b/src/OpenCV/Extra.hs @@ -0,0 +1,12 @@ +{-# OPTIONS_GHC -fno-warn-dodgy-exports #-} + +module OpenCV.Extra + ( module Extra + ) where + +import OpenCV.Extra.ArUco as Extra +import OpenCV.Extra.Bgsegm as Extra +import OpenCV.Extra.Tracking as Extra +import OpenCV.Extra.XFeatures2d as Extra +import OpenCV.Extra.XPhoto as Extra +import OpenCV.Extra.XPhoto.WhiteBalancer as Extra diff --git a/src/OpenCV/Extra/ArUco.cpp b/src/OpenCV/Extra/ArUco.cpp new file mode 100644 --- /dev/null +++ b/src/OpenCV/Extra/ArUco.cpp @@ -0,0 +1,253 @@ + +#include "opencv2/aruco.hpp" + +#include "opencv2/aruco/charuco.hpp" + +#include "opencv2/core.hpp" + +#include "iostream" + +#include "aruco.hpp" + +using namespace cv; + +using namespace cv::aruco; + +using namespace std; + +extern "C" { +bool inline_c_OpenCV_Extra_ArUco_0_bd5552a5292d57848d9aa88652d764e8c9c42af4(VectorVectorPoint2f * carucoCorners_27_inline_c_0, VectorInt * carucoIds_27_inline_c_1, Mat * imagePtr_inline_c_2, Ptr_CharucoBoard * ccharucoBoard_27_inline_c_3, Mat ** charucoIdsPtr_inline_c_4, Mat ** charucoCornersPtr_inline_c_5) { + + auto & corners = *carucoCorners_27_inline_c_0; + auto & ids = *carucoIds_27_inline_c_1; + auto & frame = *imagePtr_inline_c_2; + + auto charucoCorners = new Mat(); + auto charucoIds = new Mat(); + + interpolateCornersCharuco(corners, + ids, + frame, + *ccharucoBoard_27_inline_c_3, + *charucoCorners, + *charucoIds); + + *charucoIdsPtr_inline_c_4 = charucoIds; + *charucoCornersPtr_inline_c_5 = charucoCorners; + + return !charucoIds->empty(); + +} + +} + +extern "C" { +bool inline_c_OpenCV_Extra_ArUco_1_615bf459fee0dd377cb9469a903293b632daa6ef(Mat * ccornersPtr_27_inline_c_0, Mat * cidsPtr_27_inline_c_1, Ptr_CharucoBoard * ccharucoBoard_27_inline_c_2, Matx33d * ccameraMatrix_27_inline_c_3, Matx51d * cdistCoeffs_27_inline_c_4, Vec3d * rvecPtr_inline_c_5, Vec3d * tvecPtr_inline_c_6) { + + return estimatePoseCharucoBoard(*ccornersPtr_27_inline_c_0, + *cidsPtr_27_inline_c_1, + *ccharucoBoard_27_inline_c_2, + *ccameraMatrix_27_inline_c_3, + *cdistCoeffs_27_inline_c_4, + *rvecPtr_inline_c_5, + *tvecPtr_inline_c_6); + +} + +} + +extern "C" { +void inline_c_OpenCV_Extra_ArUco_2_97babe245258febd5fd31065cc0da01bf14d0b96(Mat * imagePtr_inline_c_0, Matx33d * ccameraMatrix_27_inline_c_1, Matx51d * cdistCoeffs_27_inline_c_2, Vec3d * rvecPtr_inline_c_3, Vec3d * tvecPtr_inline_c_4) { + + drawAxis(*imagePtr_inline_c_0, + *ccameraMatrix_27_inline_c_1, + *cdistCoeffs_27_inline_c_2, + *rvecPtr_inline_c_3, + *tvecPtr_inline_c_4, + 1); + +} + +} + +extern "C" { +Exception * inline_c_OpenCV_Extra_ArUco_3_189a51fbfeacf22e1e41218ae5f7f2c90ddd95ff(long callCorners_27_inline_c_0, VectorVectorPoint2f ** callCorners_27_inline_c_1, long callIds_27_inline_c_2, VectorInt ** callIds_27_inline_c_3, int cwidth_27_inline_c_4, int cheight_27_inline_c_5, Ptr_CharucoBoard * cboard_27_inline_c_6, Matx33d * cameraMatrixPtr_inline_c_7, Matx51d * distCoeffsPtr_inline_c_8, long callCharucoCorners_27_inline_c_9, Mat ** callCharucoCorners_27_inline_c_10, long callCharucoIds_27_inline_c_11, Mat ** callCharucoIds_27_inline_c_12, Matx33d * cameraMatrixPtr_inline_c_13, Matx51d * distCoeffsPtr_inline_c_14) { + + try + { + vector< vector > allCorners; + for(auto i = 0; i < callCorners_27_inline_c_0; i++) { + auto & corners = + *callCorners_27_inline_c_1[i]; + + allCorners.insert(allCorners.end(), corners.begin(), corners.end()); + } + + vector allIds; + vector counter; + for(auto i = 0; i < callIds_27_inline_c_2; i++) { + auto & ids = *callIds_27_inline_c_3[i]; + allIds.insert(allIds.end(), ids.begin(), ids.end()); + counter.push_back(ids.size()); + } + + Size frameSize(cwidth_27_inline_c_4, cheight_27_inline_c_5); + + Ptr charucoBoard = *cboard_27_inline_c_6; + Ptr board = charucoBoard.staticCast(); + + calibrateCameraAruco(allCorners, + allIds, + counter, + board, + frameSize, + *cameraMatrixPtr_inline_c_7, + *distCoeffsPtr_inline_c_8); + + vector allCharucoCorners; + for(auto i = 0; i < callCharucoCorners_27_inline_c_9; i++) { + auto & corners = *callCharucoCorners_27_inline_c_10[i]; + allCharucoCorners.push_back(corners); + } + + vector allCharucoIds; + for(auto i = 0; i < callCharucoIds_27_inline_c_11; i++) { + auto & ids = *callCharucoIds_27_inline_c_12[i]; + allCharucoIds.push_back(ids); + } + + Mat perViewErrors; + + calibrateCameraCharuco(allCharucoCorners, + allCharucoIds, + charucoBoard, + frameSize, + *cameraMatrixPtr_inline_c_13, + *distCoeffsPtr_inline_c_14, + noArray(), + noArray(), + noArray(), + noArray(), + perViewErrors); + + return NULL; + } + catch (const cv::Exception & e) + { + return new cv::Exception(e); + } + +} + +} + +extern "C" { +bool inline_c_OpenCV_Extra_ArUco_4_e65bd42c3a4ec69183769f1d3abbc8dc9ac21c29(Mat * imagePtr_inline_c_0, Ptr_Dictionary * cdictionary_27_inline_c_1, VectorVectorPoint2f ** cornersOutPtr_inline_c_2, VectorInt ** idsOutPtr_inline_c_3) { + + auto * corners = new vector< vector >(); + auto * ids = new vector(); + + detectMarkers(*imagePtr_inline_c_0, + *cdictionary_27_inline_c_1, + *corners, + *ids); + + *cornersOutPtr_inline_c_2 = corners; + *idsOutPtr_inline_c_3 = ids; + return ids->size() > 0; + +} + +} + +extern "C" { +void inline_c_OpenCV_Extra_ArUco_5_e103b2a6072343f5d389cb9096058d5b33defc59(Mat * imagePtr_inline_c_0, VectorVectorPoint2f * ccornersPtr_27_inline_c_1, VectorInt * cidsPtr_27_inline_c_2) { + + drawDetectedMarkers(*imagePtr_inline_c_0, + *ccornersPtr_27_inline_c_1, + *cidsPtr_27_inline_c_2); + +} + +} + +extern "C" { +void inline_c_OpenCV_Extra_ArUco_6_37feba18e64b5c7115da15bd570386759895c7a2(Mat * imagePtr_inline_c_0, Mat * ccornersPtr_27_inline_c_1, Mat * cidsPtr_27_inline_c_2) { + + drawDetectedCornersCharuco(*imagePtr_inline_c_0, + *ccornersPtr_27_inline_c_1, + *cidsPtr_27_inline_c_2); + +} + +} + +extern "C" { +Ptr_CharucoBoard * inline_c_OpenCV_Extra_ArUco_7_30fe6411bb487a62b7005f44d34773c8ce51511a(int csquaresX_27_inline_c_0, int csquaresY_27_inline_c_1, double csquareLength_27_inline_c_2, double cmarkerLength_27_inline_c_3, Ptr_Dictionary * cdictionary_27_inline_c_4) { + + return + new Ptr(CharucoBoard::create(csquaresX_27_inline_c_0, + csquaresY_27_inline_c_1, + csquareLength_27_inline_c_2, + cmarkerLength_27_inline_c_3, + *cdictionary_27_inline_c_4)); + +} + +} + +extern "C" { +int inline_c_OpenCV_Extra_ArUco_8_7ede7ba79559132935c117a79d32f29421fb5af7() { +return ( DICT_7X7_1000 ); +} + +} + +extern "C" { +Ptr_Dictionary * inline_c_OpenCV_Extra_ArUco_9_e043f809501b147d4172ef13477613254e4c1009(int cname_27_inline_c_0) { + + return + new Ptr(getPredefinedDictionary(cname_27_inline_c_0)); + +} + +} + +extern "C" { +void inline_c_OpenCV_Extra_ArUco_10_1660ae62bf4004a4267ef43424eaa8c162afdea4(Mat * dstPtr_inline_c_0, Ptr_CharucoBoard * cboard_27_inline_c_1, int32_t w_inline_c_2, int32_t h_inline_c_3) { + + Mat & board = * dstPtr_inline_c_0; + Ptr & charucoBoard = *cboard_27_inline_c_1; + charucoBoard->draw(cv::Size(w_inline_c_2, h_inline_c_3), board); + +} + +} + +extern "C" { +void inline_c_OpenCV_Extra_ArUco_11_26c5e19bfe16c79e7bf651cb378e30fd432cd99b(VectorVectorPoint2f * ptr_inline_c_0) { + delete ptr_inline_c_0; +} + +} + +extern "C" { +void inline_c_OpenCV_Extra_ArUco_12_86f8b8c429a70629e07c27698801886a0484dfef(VectorInt * ptr_inline_c_0) { + delete ptr_inline_c_0; +} + +} + +extern "C" { +void inline_c_OpenCV_Extra_ArUco_13_a3285f65e0699baa139781baf5bb261b6fa6aa9d(Ptr_CharucoBoard * ptr_inline_c_0) { + delete ptr_inline_c_0; +} + +} + +extern "C" { +void inline_c_OpenCV_Extra_ArUco_14_35320368ab79414e41da235a390ce49c04ab0a5c(Ptr_Dictionary * ptr_inline_c_0) { + delete ptr_inline_c_0; +} + +} diff --git a/src/OpenCV/Extra/ArUco.hs b/src/OpenCV/Extra/ArUco.hs new file mode 100644 --- /dev/null +++ b/src/OpenCV/Extra/ArUco.hs @@ -0,0 +1,539 @@ +{-# LANGUAGE DataKinds, QuasiQuotes, RecordWildCards, TemplateHaskell #-} + +module OpenCV.Extra.ArUco + ( -- * ArUco markers + -- ** Dictionaries + Dictionary + , PredefinedDictionaryName(..) + , getPredefinedDictionary + + -- ** Detecting markers + , detectMarkers + , ArUcoMarkers + + -- ** Visualising ArUco markers + , drawDetectedMarkers + + -- * ChArUco markers + , ChArUcoBoard + , createChArUcoBoard + , drawChArUcoBoard + + -- ** Detecting markers + , interpolateChArUcoMarkers + , estimatePoseChArUcoBoard + + -- ** Camera calibration + , calibrateCameraFromFrames + + -- ** Debugging and visualiation utilities + , drawDetectedCornersCharuco + , drawEstimatedPose + ) where + +import "opencv" OpenCV.Internal.Exception +import "base" Control.Monad (guard) +import "primitive" Control.Monad.Primitive +import "base" Data.Monoid ((<>)) +import "base" Data.Word ( Word8 ) +import qualified "vector" Data.Vector.Storable as SV +import "base" Foreign.C +import "base" Foreign.ForeignPtr (ForeignPtr, withForeignPtr) +import "base" Foreign.Marshal.Alloc +import "base" Foreign.Ptr +import "base" Foreign.Storable (peek) +import qualified "inline-c" Language.C.Inline as C +import qualified "inline-c-cpp" Language.C.Inline.Cpp as C +import qualified "inline-c" Language.C.Inline.Unsafe as CU +import "linear" Linear +import "opencv" OpenCV +import "opencv" OpenCV.Core.Types.Vec (Vec3d) +import "this" OpenCV.Extra.Internal.C.Inline ( openCvExtraCtx ) +import "this" OpenCV.Extra.Internal.C.Types +import "opencv" OpenCV.Internal +import "opencv" OpenCV.Internal.C.Types +import "opencv" OpenCV.Internal.Core.Types.Mat +import "base" System.IO.Unsafe + +-------------------------------------------------------------------------------- +C.context openCvExtraCtx + +C.include "opencv2/aruco.hpp" +C.include "opencv2/aruco/charuco.hpp" +C.include "opencv2/core.hpp" +C.include "iostream" +C.include "aruco.hpp" + +C.using "namespace cv" +C.using "namespace cv::aruco" +C.using "namespace std" + +{-| A @Dictionary@ describes the possible QR codes used for ArUco markers. Use +'getPredefinedDictionary' to lookup known dictionaries. +-} +newtype Dictionary = Dictionary + { unDictionary :: ForeignPtr C'Ptr'Dictionary + } + + +type instance C Dictionary = C'Ptr'Dictionary + + +instance FromPtr Dictionary where + fromPtr = + objFromPtr Dictionary $ \ptr -> + [CU.block| void { delete $(Ptr_Dictionary * ptr); }|] + + +instance WithPtr Dictionary where + withPtr = withForeignPtr . unDictionary + + + +{-| A ChArUco board is used to perform camera calibration from ArUco markers +overlaid on a chess board of known size. Use 'createChArUcoBoard' to create +values of this type. +-} +newtype ChArUcoBoard = ChArUcoBoard + { unChArUcoBoard :: ForeignPtr C'Ptr'CharucoBoard + } + + +type instance C ChArUcoBoard = C'Ptr'CharucoBoard + + +instance FromPtr ChArUcoBoard where + fromPtr = + objFromPtr ChArUcoBoard $ \ptr -> + [CU.block| void { delete $(Ptr_CharucoBoard * ptr); }|] + + +instance WithPtr ChArUcoBoard where + withPtr = withForeignPtr . unChArUcoBoard + + +newtype Vector'Int = Vector'Int + { unVectorInt :: ForeignPtr C'Vector'Int + } + + +type instance C Vector'Int = C'Vector'Int + + +instance FromPtr Vector'Int where + fromPtr = + objFromPtr Vector'Int $ \ptr -> + [CU.block| void { delete $(VectorInt * ptr); }|] + + +instance WithPtr Vector'Int where + withPtr = withForeignPtr . unVectorInt + + +newtype Vector'Vector'Point2f = Vector'Vector'Point2f + { unVectorVectorPoint2f :: ForeignPtr C'Vector'Vector'Point2f + } + + +type instance C Vector'Vector'Point2f = C'Vector'Vector'Point2f + + +instance FromPtr Vector'Vector'Point2f where + fromPtr = + objFromPtr Vector'Vector'Point2f $ \ptr -> + [CU.block| void { delete $(VectorVectorPoint2f * ptr); }|] + + +instance WithPtr Vector'Vector'Point2f where + withPtr = withForeignPtr . unVectorVectorPoint2f + + +{-| An encoding of the result of 'interpolateChArUcoMarkers'. +-} +data ChArUcoMarkers = ChArUcoMarkers + { charucoIds :: Mat 'D 'D 'D + , charucoCorners :: Mat 'D 'D 'D + } + + +{-| Given an image and the detected ArUco markers in that image, attempt to +perform ChAruco calibration. +-} +interpolateChArUcoMarkers + :: ChArUcoBoard + -- ^ The ChArUco board to interpolate markers for. + -> Mat ('S '[ h, w]) channels depth + -- ^ A view of a ChArUco board. + -> ArUcoMarkers + -- ^ The ArUco markers detected in the same image. + -> Maybe ChArUcoMarkers +interpolateChArUcoMarkers charucoBoard image ArUcoMarkers {..} = + unsafePerformIO $ + alloca $ \charucoCornersPtr -> + alloca $ \charucoIdsPtr -> + withPtr arucoCorners $ \c'arucoCorners -> + withPtr arucoIds $ \c'arucoIds -> + withPtr image $ \imagePtr -> + withPtr charucoBoard $ \c'charucoBoard -> do + success <- + [C.block| bool { + auto & corners = *$(VectorVectorPoint2f * c'arucoCorners); + auto & ids = *$(VectorInt * c'arucoIds); + auto & frame = *$(Mat * imagePtr); + + auto charucoCorners = new Mat(); + auto charucoIds = new Mat(); + + interpolateCornersCharuco(corners, + ids, + frame, + *$(Ptr_CharucoBoard * c'charucoBoard), + *charucoCorners, + *charucoIds); + + *$(Mat * * charucoIdsPtr) = charucoIds; + *$(Mat * * charucoCornersPtr) = charucoCorners; + + return !charucoIds->empty(); + }|] + ids <- fromPtr (peek charucoIdsPtr) + corners <- fromPtr (peek charucoCornersPtr) + return (ChArUcoMarkers ids corners <$ guard (success /= 0)) + + +{- | Given an image, the ChArUco markers in that image, and the camera +calibration, estimate the pose of the board. +-} +estimatePoseChArUcoBoard + :: ChArUcoBoard + -- ^ The ChArUco board parameters. + -> ChArUcoMarkers + -- ^ Detected ChArUco markers. + -> (Matx33d, Matx51d) + -- ^ A pair of the camera intrinsic parameters and a 5 dimensional vector + -- of distortion coefficients. + -> Maybe (Vec3d, Vec3d) +estimatePoseChArUcoBoard charucoBoard ChArUcoMarkers {..} (cameraMatrix, distCoeffs) = + unsafePerformIO $ do + rvec <- toVecIO (V3 0.0 0.0 0.0) + tvec <- toVecIO (V3 0.0 0.0 0.0) + withPtr cameraMatrix $ \c'cameraMatrix -> + withPtr distCoeffs $ \c'distCoeffs -> + withPtr charucoIds $ \c'idsPtr -> + withPtr charucoBoard $ \c'charucoBoard -> + withPtr rvec $ \rvecPtr -> + withPtr tvec $ \tvecPtr -> + withPtr charucoCorners $ \c'cornersPtr -> do + success <- [C.block| bool { + return estimatePoseCharucoBoard(*$(Mat * c'cornersPtr), + *$(Mat * c'idsPtr), + *$(Ptr_CharucoBoard * c'charucoBoard), + *$(Matx33d * c'cameraMatrix), + *$(Matx51d * c'distCoeffs), + *$(Vec3d * rvecPtr), + *$(Vec3d * tvecPtr)); + }|] + return (( fromVec rvec , fromVec tvec) <$ guard (success /= 0)) + + +{- | Given an estimated pose for a board, draw the axis over an image. +-} + +drawEstimatedPose + :: PrimMonad m + => Matx33d + -- ^ The matrix of intrinsic parameters of a camera. + -> Matx51d + -- ^ A 5-dimensional vector of distortion coefficients. + -> (Vec3d, Vec3d) + -- ^ The transposition and rotation matrices from local to camera space, + -- respectively. + -> Mut (Mat ('S '[ h, w]) channels depth) (PrimState m) + -- ^ An image to draw the axis onto. + -> m () +drawEstimatedPose cameraMatrix distCoeffs (rvec, tvec) image = + unsafePrimToPrim $ do + withPtr image $ \imagePtr -> + withPtr cameraMatrix $ \c'cameraMatrix -> + withPtr distCoeffs $ \c'distCoeffs -> + withPtr rvec $ \rvecPtr -> + withPtr tvec $ \tvecPtr -> + [C.block| void { + drawAxis(*$(Mat * imagePtr), + *$(Matx33d * c'cameraMatrix), + *$(Matx51d * c'distCoeffs), + *$(Vec3d * rvecPtr), + *$(Vec3d * tvecPtr), + 1); + }|] + + +{- | Given a list of ChArUco calibration results, combine all results into +camera calibration. +-} +calibrateCameraFromFrames + :: ChArUcoBoard + -> Int + -> Int + -> [(ArUcoMarkers, ChArUcoMarkers)] + -> CvExcept (Matx33d, Matx51d) +calibrateCameraFromFrames board width height frames = + unsafeWrapException $ do + cameraMatrix <- newMatx33d 0 0 0 0 0 0 0 0 0 + distCoeffs <- newMatx51d 0 0 0 0 0 + handleCvException (pure (cameraMatrix, distCoeffs)) $ + withPtr cameraMatrix $ \cameraMatrixPtr -> + withPtr distCoeffs $ \distCoeffsPtr -> + withPtr board $ \c'board -> + withPtrs (map (arucoIds . fst) frames) $ \c'allIds -> + withPtrs (map (arucoCorners . fst) frames) $ \c'allCorners -> + withPtrs (fmap (charucoCorners . snd) frames) $ \c'allCharucoCorners -> + withPtrs (fmap (charucoIds . snd) frames) $ \c'allCharucoIds -> do + + [cvExcept| + vector< vector > allCorners; + for(auto i = 0; i < $vec-len:c'allCorners; i++) { + auto & corners = + *$vec-ptr:(VectorVectorPoint2f * * c'allCorners)[i]; + + allCorners.insert(allCorners.end(), corners.begin(), corners.end()); + } + + vector allIds; + vector counter; + for(auto i = 0; i < $vec-len:c'allIds; i++) { + auto & ids = *$vec-ptr:(VectorInt * * c'allIds)[i]; + allIds.insert(allIds.end(), ids.begin(), ids.end()); + counter.push_back(ids.size()); + } + + Size frameSize($(int c'width), $(int c'height)); + + Ptr charucoBoard = *$(Ptr_CharucoBoard * c'board); + Ptr board = charucoBoard.staticCast(); + + calibrateCameraAruco(allCorners, + allIds, + counter, + board, + frameSize, + *$(Matx33d * cameraMatrixPtr), + *$(Matx51d * distCoeffsPtr)); + + vector allCharucoCorners; + for(auto i = 0; i < $vec-len:c'allCharucoCorners; i++) { + auto & corners = *$vec-ptr:(Mat * * c'allCharucoCorners)[i]; + allCharucoCorners.push_back(corners); + } + + vector allCharucoIds; + for(auto i = 0; i < $vec-len:c'allCharucoIds; i++) { + auto & ids = *$vec-ptr:(Mat * * c'allCharucoIds)[i]; + allCharucoIds.push_back(ids); + } + + Mat perViewErrors; + + calibrateCameraCharuco(allCharucoCorners, + allCharucoIds, + charucoBoard, + frameSize, + *$(Matx33d * cameraMatrixPtr), + *$(Matx51d * distCoeffsPtr), + noArray(), + noArray(), + noArray(), + noArray(), + perViewErrors); + |] + where + c'width = fromIntegral width + c'height = fromIntegral height + + +{- | The result of calling 'detectMarkers' on an image. +-} +data ArUcoMarkers = ArUcoMarkers + { arucoCorners :: Vector'Vector'Point2f + , arucoIds :: Vector'Int + } + + +{- | Perform ArUco marker detection. +-} +detectMarkers + :: Dictionary + -- ^ A dictionary describing ArUco markers. + -> Mat ('S '[ h, w]) channels depth + -- ^ The matrix to detect markers from. + -> Maybe ArUcoMarkers +detectMarkers dictionary image = + unsafePerformIO $ + withPtr image $ \imagePtr -> + withPtr dictionary $ \c'dictionary -> + alloca $ \cornersOutPtr -> + alloca $ \idsOutPtr -> do + success <- fmap (/= 0) $ + [C.block| bool { + auto * corners = new vector< vector >(); + auto * ids = new vector(); + + detectMarkers(*$(Mat * imagePtr), + *$(Ptr_Dictionary * c'dictionary), + *corners, + *ids); + + *$(VectorVectorPoint2f * * cornersOutPtr) = corners; + *$(VectorInt * * idsOutPtr) = ids; + return ids->size() > 0; + }|] + corners <- fromPtr (peek cornersOutPtr) + ids <- fromPtr (peek idsOutPtr) + return (ArUcoMarkers corners ids <$ guard success) + + +{- | Given a frame, overlay the result of ArUco marker detection. +-} +drawDetectedMarkers + :: PrimMonad m + => Mut (Mat ('S [h, w]) channels depth) (PrimState m) + -- ^ The image to draw detected markers onto. Usually the same image you + -- detected markers from. + -> ArUcoMarkers + -- ^ The ArUco markers to draw. + -> m () +drawDetectedMarkers image ArUcoMarkers{..} = + unsafePrimToPrim $ + withPtr image $ \imagePtr -> + withPtr arucoCorners $ \c'cornersPtr -> + withPtr arucoIds $ \c'idsPtr -> + [C.block| void { + drawDetectedMarkers(*$(Mat * imagePtr), + *$(VectorVectorPoint2f * c'cornersPtr), + *$(VectorInt * c'idsPtr)); + }|] + + +{- | Given a frame, overlay the result of ChArUco marker detection. +-} +drawDetectedCornersCharuco + :: PrimMonad m + => Mut (Mat ('S '[ h, w]) channels depth) (PrimState m) + -- ^ The image to draw detected corners. + -> ChArUcoMarkers + -- ^ The ChArUco markers corners to draw. + -> m () +drawDetectedCornersCharuco image ChArUcoMarkers{..} = + unsafePrimToPrim $ + withPtr image $ \imagePtr -> + withPtr charucoIds $ \c'idsPtr -> + withPtr charucoCorners $ \c'cornersPtr -> + [C.block| void { + drawDetectedCornersCharuco(*$(Mat * imagePtr), + *$(Mat * c'cornersPtr), + *$(Mat * c'idsPtr)); + }|] + + +{-| Create a new ChArUco board configuration. +-} +createChArUcoBoard + :: Int + -- ^ The amount of squares along the X-axis. + -> Int + -- ^ The amount of squares along the Y-axis. + -> Double + -- ^ The length of a side of a chess-board square. + -> Double + -- ^ The length of a marker's side within a chess-board square. + -> Dictionary + -- ^ The dictionary of ArUco markers. + -> ChArUcoBoard +createChArUcoBoard squaresX squaresY squareLength markerLength dictionary = + unsafePerformIO $ + withPtr dictionary $ \c'dictionary -> + fromPtr $ + [C.block| Ptr_CharucoBoard * { + return + new Ptr(CharucoBoard::create($(int c'squaresX), + $(int c'squaresY), + $(double c'squareLength), + $(double c'markerLength), + *$(Ptr_Dictionary * c'dictionary))); + }|] + where c'squaresX = fromIntegral squaresX + c'squaresY = fromIntegral squaresY + c'squareLength = realToFrac squareLength + c'markerLength = realToFrac markerLength + + +{-| The set of predefined ArUco dictionaries known to OpenCV. +-} +data PredefinedDictionaryName = DICT_7X7_1000 + + +{-| Turn a predefined dictionary name into a ArUco dictionary. +-} +getPredefinedDictionary :: PredefinedDictionaryName -> Dictionary +getPredefinedDictionary name = + unsafePerformIO $ + fromPtr $ + [C.block| Ptr_Dictionary * { + return + new Ptr(getPredefinedDictionary($(int c'name))); + }|] + where + c'name = + case name of + DICT_7X7_1000 -> [C.pure| int { DICT_7X7_1000 } |] + + +{-| Draw a ChArUco board, ready to be printed and used for calibration/marke +detection. + +Example: + +@ +drawChArUcoBoardImg + :: forall (w :: Nat) (h :: Nat) + . (w ~ 500, h ~ 500) + => Mat ('S '[ 'S h, 'S w]) ('S 1) ('S Word8) +drawChArUcoBoardImg = + drawChArUcoBoard charucoBoard (Proxy :: Proxy w) (Proxy :: Proxy h) + where + charucoBoard :: ChArUcoBoard + charucoBoard = createChArUcoBoard 10 10 20 5 dictionary + + dictionary :: Dictionary + dictionary = getPredefinedDictionary DICT_7X7_1000 +@ + +<> +-} +drawChArUcoBoard + :: (ToInt32 w, ToInt32 h) + => ChArUcoBoard + -> w -- ^ width + -> h -- ^ height + -> Mat ('S '[DSNat h, DSNat w]) ('S 1) ('S Word8) +drawChArUcoBoard charucoBoard width height = unsafePerformIO $ do + dst <- newEmptyMat + withPtr charucoBoard $ \c'board -> + withPtr dst $ \dstPtr -> + [C.block| void { + Mat & board = * $(Mat * dstPtr); + Ptr & charucoBoard = *$(Ptr_CharucoBoard * c'board); + charucoBoard->draw(cv::Size($(int32_t w), $(int32_t h)), board); + }|] + pure (unsafeCoerceMat dst) + where + w = toInt32 width + h = toInt32 height + +-------------------------------------------------------------------------------- +withPtrs + :: WithPtr a + => [a] -> (SV.Vector (Ptr (C a)) -> IO b) -> IO b +withPtrs [] io = io mempty +withPtrs (x:xs) io = + withPtr x $ \ptr -> withPtrs xs $ \sv -> io (SV.singleton ptr <> sv) diff --git a/src/OpenCV/Extra/Bgsegm.cpp b/src/OpenCV/Extra/Bgsegm.cpp new file mode 100644 --- /dev/null +++ b/src/OpenCV/Extra/Bgsegm.cpp @@ -0,0 +1,152 @@ + +#include "opencv2/core.hpp" + +#include "opencv2/video.hpp" + +#include "opencv2/bgsegm.hpp" + +#include "bgsegm.hpp" + +using namespace cv; + +extern "C" { +Ptr_BackgroundSubtractorGMG * inline_c_OpenCV_Extra_Bgsegm_0_4cad742a94b1e290a850aaa42019ad34d95bdaea(int32_t cinitializationFrames_27_inline_c_0, double cdecisionThreshold_27_inline_c_1) { + + cv::Ptr gmgPtr = + cv::bgsegm::createBackgroundSubtractorGMG + ( cinitializationFrames_27_inline_c_0 + , cdecisionThreshold_27_inline_c_1 + ); + return new cv::Ptr(gmgPtr); + +} + +} + +extern "C" { +Ptr_BackgroundSubtractorMOG * inline_c_OpenCV_Extra_Bgsegm_1_546b1da302dc708e3c4ddc702cd20cd72c8559b7(int32_t chistory_27_inline_c_0, int32_t cnumGausianMix_27_inline_c_1, double cbackgroundRatio_27_inline_c_2, double cnoise_27_inline_c_3) { + + cv::Ptr mog2Ptr = + cv::bgsegm::createBackgroundSubtractorMOG + ( chistory_27_inline_c_0 + , cnumGausianMix_27_inline_c_1 + , cbackgroundRatio_27_inline_c_2 + , cnoise_27_inline_c_3 + ); + return new cv::Ptr(mog2Ptr); + +} + +} + +extern "C" { +void inline_c_OpenCV_Extra_Bgsegm_2_48cb6527f13d74249e3e1955e1f02f2011cee17a(Ptr_BackgroundSubtractorMOG * mogPtr_inline_c_0, Mat * imgPtr_inline_c_1, Mat * fgMaskPtr_inline_c_2, double clearningRate_27_inline_c_3) { + + cv::bgsegm::BackgroundSubtractorMOG * mog = *mogPtr_inline_c_0; + mog->apply + ( *imgPtr_inline_c_1 + , *fgMaskPtr_inline_c_2 + , clearningRate_27_inline_c_3 + ); + +} + +} + +extern "C" { +void inline_c_OpenCV_Extra_Bgsegm_3_cbba6f9c69ed88c9000d7dd2775444c61982293b(Ptr_BackgroundSubtractorMOG * mogPtr_inline_c_0, Mat * imgPtr_inline_c_1) { + + cv::bgsegm::BackgroundSubtractorMOG * mog = *mogPtr_inline_c_0; + mog->getBackgroundImage(*imgPtr_inline_c_1); + +} + +} + +extern "C" { +void inline_c_OpenCV_Extra_Bgsegm_4_10eb3318bc5306fecb2320251a25b410f89c160c(Ptr_BackgroundSubtractorGMG * gmgPtr_inline_c_0, Mat * imgPtr_inline_c_1, Mat * fgMaskPtr_inline_c_2, double clearningRate_27_inline_c_3) { + + cv::bgsegm::BackgroundSubtractorGMG * gmg = *gmgPtr_inline_c_0; + gmg->apply + ( *imgPtr_inline_c_1 + , *fgMaskPtr_inline_c_2 + , clearningRate_27_inline_c_3 + ); + +} + +} + +extern "C" { +void inline_c_OpenCV_Extra_Bgsegm_5_c960b2287d0171e2659a7072d345ffaee412eede(Ptr_BackgroundSubtractorGMG * gmgPtr_inline_c_0, Mat * imgPtr_inline_c_1) { + + cv::bgsegm::BackgroundSubtractorGMG * gmg = *gmgPtr_inline_c_0; + gmg->getBackgroundImage(*imgPtr_inline_c_1); + +} + +} + +extern "C" { +void inline_c_OpenCV_Extra_Bgsegm_6_dc2609be8bceffb0014796e658ebe95c73d04536(Ptr_BackgroundSubtractorMOG * mog2Ptr_inline_c_0) { + + cv::bgsegm::BackgroundSubtractorMOG * mog2 = *mog2Ptr_inline_c_0; + mog2->clear(); + +} + +} + +extern "C" { +void inline_c_OpenCV_Extra_Bgsegm_7_c26d79c05f7057ecd9dee235ac9dca2d2d89a9ca(Ptr_BackgroundSubtractorMOG * mog2Ptr_inline_c_0, bool * emptyPtr_inline_c_1) { + + cv::bgsegm::BackgroundSubtractorMOG * mog2 = *mog2Ptr_inline_c_0; + *emptyPtr_inline_c_1 = mog2->empty(); + +} + +} + +extern "C" { +void inline_c_OpenCV_Extra_Bgsegm_8_030580224eb15175e4895cb174cbdf0348b871e6(Ptr_BackgroundSubtractorGMG * knnPtr_inline_c_0) { + + cv::bgsegm::BackgroundSubtractorGMG * knn = *knnPtr_inline_c_0; + knn->clear(); + +} + +} + +extern "C" { +void inline_c_OpenCV_Extra_Bgsegm_9_6f8b16403e735ccf26882c73dc3e6bdcd6dfac7b(Ptr_BackgroundSubtractorGMG * gmgPtr_inline_c_0, bool * emptyPtr_inline_c_1) { + + cv::bgsegm::BackgroundSubtractorGMG * gmg = *gmgPtr_inline_c_0; + *emptyPtr_inline_c_1 = gmg->empty(); + +} + +} + +extern "C" { +void inline_c_OpenCV_Extra_Bgsegm_10_f2dd1537a7c6649e59499980d21e3efce8309c8a(Ptr_BackgroundSubtractorMOG * ptr_inline_c_0) { + + cv::Ptr * mog2_ptr_ptr = + ptr_inline_c_0; + mog2_ptr_ptr->release(); + delete mog2_ptr_ptr; + +} + +} + +extern "C" { +void inline_c_OpenCV_Extra_Bgsegm_11_453105bb3402b7542dceb42b6f82b21e8c2340b9(Ptr_BackgroundSubtractorGMG * ptr_inline_c_0) { + + cv::Ptr * knn_ptr_ptr = + ptr_inline_c_0; + knn_ptr_ptr->release(); + delete knn_ptr_ptr; + +} + +} diff --git a/src/OpenCV/Extra/Bgsegm.hs b/src/OpenCV/Extra/Bgsegm.hs new file mode 100644 --- /dev/null +++ b/src/OpenCV/Extra/Bgsegm.hs @@ -0,0 +1,229 @@ +{-# language TemplateHaskell #-} +{-# language QuasiQuotes #-} + +{- | +Two additional background subtraction algorithms. These algorithms do +not support `getBackgroundImage` (and probably never will). +-} +module OpenCV.Extra.Bgsegm + ( -- * Background subtractors + BackgroundSubtractorGMG + , BackgroundSubtractorMOG + + , newBackgroundSubtractorGMG + , newBackgroundSubtractorMOG + ) where + +import "base" Control.Exception ( mask_ ) +import "base" Data.Int +import "base" Data.Maybe +import "base" Foreign.ForeignPtr ( ForeignPtr, withForeignPtr ) +import "base" Foreign.Marshal.Alloc ( alloca ) +import "base" Foreign.Marshal.Utils ( toBool ) +import "base" Foreign.Storable ( peek ) +import qualified "inline-c" Language.C.Inline as C +import qualified "inline-c" Language.C.Inline.Unsafe as CU +import qualified "inline-c-cpp" Language.C.Inline.Cpp as C +import "opencv" OpenCV.Core.Types +import "opencv" OpenCV.Internal +import "opencv" OpenCV.Internal.Core.Types.Mat +import "opencv" OpenCV.Internal.C.Types +import "opencv" OpenCV.Video.MotionAnalysis ( BackgroundSubtractor(..) ) +import "primitive" Control.Monad.Primitive +import "this" OpenCV.Extra.Internal.C.Inline ( openCvExtraCtx ) +import "this" OpenCV.Extra.Internal.C.Types + +-------------------------------------------------------------------------------- + +C.context openCvExtraCtx + +C.include "opencv2/core.hpp" +C.include "opencv2/video.hpp" +C.include "opencv2/bgsegm.hpp" +C.include "bgsegm.hpp" + +C.using "namespace cv" + +-------------------------------------------------------------------------------- + +newtype BackgroundSubtractorGMG s + = BackgroundSubtractorGMG + { unBackgroundSubtractorGMG :: ForeignPtr C'Ptr_BackgroundSubtractorGMG } + +newtype BackgroundSubtractorMOG s + = BackgroundSubtractorMOG + { unBackgroundSubtractorMOG :: ForeignPtr C'Ptr_BackgroundSubtractorMOG } + +type instance C (BackgroundSubtractorGMG s) = C'Ptr_BackgroundSubtractorGMG +type instance C (BackgroundSubtractorMOG s) = C'Ptr_BackgroundSubtractorMOG + +instance WithPtr (BackgroundSubtractorGMG s) where + withPtr = withForeignPtr . unBackgroundSubtractorGMG + +instance WithPtr (BackgroundSubtractorMOG s) where + withPtr = withForeignPtr . unBackgroundSubtractorMOG + +instance FromPtr (BackgroundSubtractorGMG s) where + fromPtr = objFromPtr BackgroundSubtractorGMG $ \ptr -> + [CU.block| void { + cv::Ptr * knn_ptr_ptr = + $(Ptr_BackgroundSubtractorGMG * ptr); + knn_ptr_ptr->release(); + delete knn_ptr_ptr; + }|] + +instance FromPtr (BackgroundSubtractorMOG s) where + fromPtr = objFromPtr BackgroundSubtractorMOG $ \ptr -> + [CU.block| void { + cv::Ptr * mog2_ptr_ptr = + $(Ptr_BackgroundSubtractorMOG * ptr); + mog2_ptr_ptr->release(); + delete mog2_ptr_ptr; + }|] + +-------------------------------------------------------------------------------- + +newBackgroundSubtractorGMG + :: (PrimMonad m) + => Maybe Int32 + -- ^ Number of frames used to initialize the background models. + -> Maybe Double + -- ^ Threshold value, above which it is marked foreground, else background. + -> m (BackgroundSubtractorGMG (PrimState m)) +newBackgroundSubtractorGMG mbInitializationFrames mbDecisionThreshold = + unsafePrimToPrim $ fromPtr + [CU.block|Ptr_BackgroundSubtractorGMG * { + cv::Ptr gmgPtr = + cv::bgsegm::createBackgroundSubtractorGMG + ( $(int32_t c'initializationFrames) + , $(double c'decisionThreshold ) + ); + return new cv::Ptr(gmgPtr); + }|] + where + c'initializationFrames = fromMaybe 120 mbInitializationFrames + c'decisionThreshold = maybe 0.8 realToFrac mbDecisionThreshold + +newBackgroundSubtractorMOG + :: (PrimMonad m) + => Maybe Int32 + -- ^ Length of the history. + -> Maybe Int32 + -- ^ Number of Gaussian mixtures. + -> Maybe Double + -- ^ Background ratio. + -> Maybe Double + -- ^ Noise strength (standard deviation of the brightness or each + -- color channel). 0 means some automatic value. + -> m (BackgroundSubtractorMOG (PrimState m)) +newBackgroundSubtractorMOG mbHistory mbNumGausianMix mbBackgroundRatio mbNoise + = unsafePrimToPrim $ fromPtr + [CU.block|Ptr_BackgroundSubtractorMOG * { + cv::Ptr mog2Ptr = + cv::bgsegm::createBackgroundSubtractorMOG + ( $(int32_t c'history ) + , $(int32_t c'numGausianMix ) + , $(double c'backgroundRatio ) + , $(double c'noise ) + ); + return new cv::Ptr(mog2Ptr); + }|] + where + c'history = fromMaybe 200 mbHistory + c'numGausianMix = fromMaybe 5 mbNumGausianMix + c'backgroundRatio = maybe 0.7 realToFrac mbBackgroundRatio + c'noise = maybe 0 realToFrac mbNoise + +-------------------------------------------------------------------------------- + +instance Algorithm BackgroundSubtractorGMG where + algorithmClearState knn = unsafePrimToPrim $ + withPtr knn $ \knnPtr -> + [C.block|void { + cv::bgsegm::BackgroundSubtractorGMG * knn = *$(Ptr_BackgroundSubtractorGMG * knnPtr); + knn->clear(); + }|] + + algorithmIsEmpty gmg = unsafePrimToPrim $ + withPtr gmg $ \gmgPtr -> + alloca $ \emptyPtr -> do + [C.block|void { + cv::bgsegm::BackgroundSubtractorGMG * gmg = *$(Ptr_BackgroundSubtractorGMG * gmgPtr); + *$(bool * emptyPtr) = gmg->empty(); + }|] + toBool <$> peek emptyPtr + +instance Algorithm BackgroundSubtractorMOG where + algorithmClearState mog2 = unsafePrimToPrim $ + withPtr mog2 $ \mog2Ptr -> + [C.block|void { + cv::bgsegm::BackgroundSubtractorMOG * mog2 = *$(Ptr_BackgroundSubtractorMOG * mog2Ptr); + mog2->clear(); + }|] + + algorithmIsEmpty mog2 = unsafePrimToPrim $ + withPtr mog2 $ \mog2Ptr -> + alloca $ \emptyPtr -> do + [C.block|void { + cv::bgsegm::BackgroundSubtractorMOG * mog2 = *$(Ptr_BackgroundSubtractorMOG * mog2Ptr); + *$(bool * emptyPtr) = mog2->empty(); + }|] + toBool <$> peek emptyPtr + +instance BackgroundSubtractor BackgroundSubtractorGMG where + bgSubApply gmg learningRate img = unsafePrimToPrim $ do + fgMask <- newEmptyMat + withPtr gmg $ \gmgPtr -> + withPtr img $ \imgPtr -> + withPtr fgMask $ \fgMaskPtr -> mask_ $ do + [C.block| void { + cv::bgsegm::BackgroundSubtractorGMG * gmg = *$(Ptr_BackgroundSubtractorGMG * gmgPtr); + gmg->apply + ( *$(Mat * imgPtr) + , *$(Mat * fgMaskPtr) + , $(double c'learningRate) + ); + }|] + pure $ unsafeCoerceMat fgMask + where + c'learningRate = realToFrac learningRate + + -- not supported by the backend + getBackgroundImage gmg = unsafePrimToPrim $ do + img <- newEmptyMat + withPtr gmg $ \gmgPtr -> + withPtr img $ \imgPtr -> mask_ $ do + [C.block| void { + cv::bgsegm::BackgroundSubtractorGMG * gmg = *$(Ptr_BackgroundSubtractorGMG * gmgPtr); + gmg->getBackgroundImage(*$(Mat * imgPtr)); + }|] + pure $ unsafeCoerceMat img + +instance BackgroundSubtractor BackgroundSubtractorMOG where + bgSubApply mog learningRate img = unsafePrimToPrim $ do + fgMask <- newEmptyMat + withPtr mog $ \mogPtr -> + withPtr img $ \imgPtr -> + withPtr fgMask $ \fgMaskPtr -> mask_ $ do + [C.block| void { + cv::bgsegm::BackgroundSubtractorMOG * mog = *$(Ptr_BackgroundSubtractorMOG * mogPtr); + mog->apply + ( *$(Mat * imgPtr) + , *$(Mat * fgMaskPtr) + , $(double c'learningRate) + ); + }|] + pure $ unsafeCoerceMat fgMask + where + c'learningRate = realToFrac learningRate + + -- not supported by the backend + getBackgroundImage mog = unsafePrimToPrim $ do + img <- newEmptyMat + withPtr mog $ \mogPtr -> + withPtr img $ \imgPtr -> mask_ $ do + [C.block| void { + cv::bgsegm::BackgroundSubtractorMOG * mog = *$(Ptr_BackgroundSubtractorMOG * mogPtr); + mog->getBackgroundImage(*$(Mat * imgPtr)); + }|] + pure $ unsafeCoerceMat img diff --git a/src/OpenCV/Extra/Internal/C/Inline.hs b/src/OpenCV/Extra/Internal/C/Inline.hs new file mode 100644 --- /dev/null +++ b/src/OpenCV/Extra/Internal/C/Inline.hs @@ -0,0 +1,49 @@ +{-# language CPP #-} +{-# language QuasiQuotes #-} +{-# language TemplateHaskell #-} + +#ifndef ENABLE_INTERNAL_DOCUMENTATION +{-# OPTIONS_HADDOCK hide #-} +#endif + +-- | Interface between OpenCV (extra modules) and inline-c(pp) (Haskell) +module OpenCV.Extra.Internal.C.Inline ( openCvExtraCtx ) where + +import "base" Data.Monoid ( (<>) ) +import qualified "containers" Data.Map as M +import qualified "inline-c" Language.C.Inline as C +import qualified "inline-c" Language.C.Types as C +import qualified "inline-c" Language.C.Inline.Context as C +import "opencv" OpenCV.Internal.C.Inline ( openCvCtx ) +import "this" OpenCV.Extra.Internal.C.Types + +-- | Context useful to work with the OpenCV library's extra modules. +-- +-- Based on 'C.cppCtx', 'C.bsCtx', 'C.vecCtx' and most importantly 'openCvCtx'. +-- +-- 'C.ctxTypesTable': converts OpenCV basic types to their counterparts in +-- "OpenCV.Internal.C.Inline". +-- +-- No 'C.ctxAntiQuoters'. +openCvExtraCtx :: C.Context +openCvExtraCtx = openCvCtx <> ctx + where + ctx = mempty { C.ctxTypesTable = openCvExtraTypesTable } + +openCvExtraTypesTable :: C.TypesTable +openCvExtraTypesTable = M.fromList + [ ( C.TypeName "Ptr_BackgroundSubtractorGMG", [t| C'Ptr_BackgroundSubtractorGMG |] ) + , ( C.TypeName "Ptr_BackgroundSubtractorMOG", [t| C'Ptr_BackgroundSubtractorMOG |] ) + , ( C.TypeName "Ptr_Tracker" , [t| C'Ptr_Tracker |] ) + , ( C.TypeName "Ptr_TrackerFeature" , [t| C'Ptr_TrackerFeature |] ) + , ( C.TypeName "Ptr_MultiTracker" , [t| C'Ptr_MultiTracker |] ) + , ( C.TypeName "Ptr_MultiTrackerAlt" , [t| C'Ptr_MultiTrackerAlt |] ) + , ( C.TypeName "Ptr_SURF" , [t| C'Ptr_SURF |] ) + , ( C.TypeName "Ptr_GrayworldWB" , [t| C'Ptr_GrayworldWB |] ) + , ( C.TypeName "Ptr_LearningBasedWB" , [t| C'Ptr_LearningBasedWB |] ) + , ( C.TypeName "Ptr_SimpleWB" , [t| C'Ptr_SimpleWB |] ) + , ( C.TypeName "Ptr_CharucoBoard" , [t| C'Ptr'CharucoBoard |] ) + , ( C.TypeName "Ptr_Dictionary" , [t| C'Ptr'Dictionary |] ) + , ( C.TypeName "VectorVectorPoint2f" , [t| C'Vector'Vector'Point2f |] ) + , ( C.TypeName "VectorInt" , [t| C'Vector'Int |] ) + ] diff --git a/src/OpenCV/Extra/Internal/C/Types.hs b/src/OpenCV/Extra/Internal/C/Types.hs new file mode 100644 --- /dev/null +++ b/src/OpenCV/Extra/Internal/C/Types.hs @@ -0,0 +1,40 @@ +{-# language CPP #-} + +#ifndef ENABLE_INTERNAL_DOCUMENTATION +{-# OPTIONS_HADDOCK hide #-} +#endif + +module OpenCV.Extra.Internal.C.Types where + +-------------------------------------------------------------------------------- + +-- | Haskell representation of an OpenCV @cv::Ptr@ object +data C'Ptr_BackgroundSubtractorGMG +-- | Haskell representation of an OpenCV @cv::Ptr@ object +data C'Ptr_BackgroundSubtractorMOG +-- | Haskell representation of an OpenCV @cv::Ptr@ object +data C'Ptr_SURF + +-- | Haskell representation of an OpenCV @cv::Ptr@ object +data C'Ptr_GrayworldWB +-- | Haskell representation of an OpenCV @cv::Ptr@ object +data C'Ptr_LearningBasedWB +-- | Haskell representation of an OpenCV @cv::Ptr@ object +data C'Ptr_SimpleWB + +-- | Haskell representation of an OpenCV @cv::Ptr@ object +data C'Ptr_Tracker +data C'Ptr_TrackerFeature +data C'Ptr_MultiTracker +data C'Ptr_MultiTrackerAlt + +data C'TrackerFeatureSet +data C'Ptr_TrackerSamplerAlgorithm + + +data C'Ptr'Dictionary +data C'Ptr'CharucoBoard + +data C'Vector'Int + +data C'Vector'Vector'Point2f diff --git a/src/OpenCV/Extra/Tracking.cpp b/src/OpenCV/Extra/Tracking.cpp new file mode 100644 --- /dev/null +++ b/src/OpenCV/Extra/Tracking.cpp @@ -0,0 +1,102 @@ + +#include "opencv2/core.hpp" + +#include "opencv2/tracking.hpp" + +#include "tracking.hpp" + +using namespace cv; + +extern "C" { +Ptr_Tracker * inline_c_OpenCV_Extra_Tracking_0_efe6eac7c3946190981535cdf313473c4fadfc96(const char * ctrackerType_27_inline_c_0) { + + cv::Ptr tacker = + cv::Tracker::create ( cv::String(ctrackerType_27_inline_c_0)); + return new cv::Ptr(tacker); + +} + +} + +extern "C" { +bool inline_c_OpenCV_Extra_Tracking_1_f5218c121fc0cacbb2549b312cc1a0f25f8d3052(Ptr_Tracker * trkPtr_inline_c_0, Mat * srcPtr_inline_c_1, Rect2d * rectPtr_inline_c_2) { + + return (*trkPtr_inline_c_0)->init + ( *srcPtr_inline_c_1 + , *rectPtr_inline_c_2 + ); + +} + +} + +extern "C" { +bool inline_c_OpenCV_Extra_Tracking_2_cfa88d7e1596b908857073456e505f8a57bfd55f(Ptr_Tracker * trkPtr_inline_c_0, Mat * srcPtr_inline_c_1, Rect2d * rectPtr_inline_c_2) { + + return (*trkPtr_inline_c_0)->update + ( *srcPtr_inline_c_1 + , *rectPtr_inline_c_2 + ); + +} + +} + +extern "C" { +Ptr_MultiTracker * inline_c_OpenCV_Extra_Tracking_3_f3a6cc587d88595f175227bf695c32d2015f0e8d(const char * ctrackerType_27_inline_c_0) { + + cv::Ptr mtracker = + new cv::MultiTracker ( cv::String(ctrackerType_27_inline_c_0)); + return new cv::Ptr(mtracker); + +} + +} + +extern "C" { +Ptr_TrackerFeature * inline_c_OpenCV_Extra_Tracking_4_ccebdf6970bfcdb2823cf254bf81c506730c3f7f(const char * ctrackerFeatureType_27_inline_c_0) { + + cv::Ptr ftracker = + cv::TrackerFeature::create ( cv::String(ctrackerFeatureType_27_inline_c_0)); + return new cv::Ptr(ftracker); + + +} + +} + +extern "C" { +void inline_c_OpenCV_Extra_Tracking_5_6622f23d9a44ed62d61cf22707e9d8ac3e4f2186(Ptr_MultiTrackerAlt * ptr_inline_c_0) { + + delete ptr_inline_c_0; + +} + +} + +extern "C" { +void inline_c_OpenCV_Extra_Tracking_6_778deb976c698e950da3d4b45362d8b29a2c2547(Ptr_MultiTracker * ptr_inline_c_0) { + + delete ptr_inline_c_0; + +} + +} + +extern "C" { +void inline_c_OpenCV_Extra_Tracking_7_a535e1801086ce360682ac32352766b0a063504e(Ptr_TrackerFeature * ptr_inline_c_0) { + + delete ptr_inline_c_0; + +} + +} + +extern "C" { +void inline_c_OpenCV_Extra_Tracking_8_89f1496eff75dd40a161328bb1f958178e2152e9(Ptr_Tracker * ptr_inline_c_0) { + + delete ptr_inline_c_0; + +} + +} diff --git a/src/OpenCV/Extra/Tracking.hs b/src/OpenCV/Extra/Tracking.hs new file mode 100644 --- /dev/null +++ b/src/OpenCV/Extra/Tracking.hs @@ -0,0 +1,214 @@ +{-# language TemplateHaskell #-} +{-# language QuasiQuotes #-} +{-# language MultiParamTypeClasses #-} + +{-# language PackageImports #-} +{-# language TypeFamilies #-} + +{- | +Tracking extra opencv module +-} + +module OpenCV.Extra.Tracking + ( Tracker(..) + , MultiTracker (..) + , MultiTrackerAlt (..) + , TrackerType (..) + , TrackerFeature (..) + , TrackerFeatureType (..) + , newTracker + , initTracker + , updateTracker + , newMultiTracker +-- , newMultiTrackerAlt + , newTrackerFeature + ) where + +import "base" Data.Word +import "base" Foreign.ForeignPtr ( ForeignPtr, withForeignPtr ) +import "base" Foreign.C.String ( withCString ) +import "base" Foreign.Marshal.Utils ( toBool ) +import qualified "inline-c" Language.C.Inline as C +import qualified "inline-c" Language.C.Inline.Unsafe as CU +import qualified "inline-c-cpp" Language.C.Inline.Cpp as C +import "opencv" OpenCV.Core.Types +import "opencv" OpenCV.Internal +import "opencv" OpenCV.TypeLevel +import "opencv" OpenCV.Internal.C.Types +import "primitive" Control.Monad.Primitive +import "this" OpenCV.Extra.Internal.C.Inline ( openCvExtraCtx ) +import "this" OpenCV.Extra.Internal.C.Types +-------------------------------------------------------------------------------- + +C.context openCvExtraCtx + +C.include "opencv2/core.hpp" +C.include "opencv2/tracking.hpp" + +C.include "tracking.hpp" + +C.using "namespace cv" +-------------------------------------------------------------------------------- + +data TrackerType + = BOOSTING -- ^ + | MIL -- ^ + | KCF -- ^ + | MEDIANFLOW -- ^ + | TLD -- ^ + deriving (Eq, Show, Enum, Bounded) + +data TrackerFeatureType + = HAAR -- ^ Haar Feature-based + | HOG -- ^ soon Histogram of Oriented Gradients features + | LBP -- ^ soon Local Binary Pattern features + | FEATURE2D -- ^ soon All types of Feature2D + deriving (Eq, Show, Enum, Bounded) + +-------------------------------------------------------------------------------- + + +newtype Tracker s = Tracker { unTracker :: ForeignPtr C'Ptr_Tracker } +type instance C (Tracker s) = C'Ptr_Tracker + +instance WithPtr (Tracker s) where + withPtr = withForeignPtr . unTracker + + +instance FromPtr (Tracker s) where + fromPtr = objFromPtr Tracker $ \ptr -> + [CU.block| void { + delete $(Ptr_Tracker * ptr); + }|] + +newTracker + :: (PrimMonad m) + => TrackerType + -- ^ Name + -> m (Tracker (PrimState m)) +newTracker trackerType = + unsafePrimToPrim $ fromPtr $ + withCString (show trackerType) $ \c'trackerType -> + [CU.block|Ptr_Tracker * { + cv::Ptr tacker = + cv::Tracker::create ( cv::String($(const char * c'trackerType))); + return new cv::Ptr(tacker); + }|] + +initTracker + :: (PrimMonad m, IsRect rect C.CDouble) + => Tracker (PrimState m) + -> Mat ('S '[ 'D, 'D]) ('D) ('D) + -> rect C.CDouble + -> m Bool +initTracker trk srcImg boundingBox = unsafePrimToPrim $ + withPtr trk $ \trkPtr -> + withPtr srcImg $ \srcPtr -> + withPtr (toRect boundingBox) $ \rectPtr -> toBool <$> + [C.block| bool { + return (*$(Ptr_Tracker * trkPtr))->init + ( *$(Mat * srcPtr) + , *$(Rect2d * rectPtr) + ); + } + |] + +updateTracker + :: (PrimMonad m) + => Tracker (PrimState m) + -> Mat ('D) ('D) ('S Word8) + -> m (Maybe (Rect C.CDouble)) +-- -> m (Maybe (Rect Int32)) +updateTracker trk srcImg = unsafePrimToPrim $ + withPtr trk $ \trkPtr -> + withPtr srcImg $ \srcPtr -> + withPtr rect $ \rectPtr -> do + ok <- toBool <$> [C.block| bool { + return (*$(Ptr_Tracker * trkPtr))->update + ( *$(Mat * srcPtr) + , *$(Rect2d * rectPtr) + ); + } + |] + return $ if ok + then + Just rect + else + Nothing + where + rect :: Rect2d + rect = toRect HRect{ hRectTopLeft = pure 0 + , hRectSize = pure 0 + } + +-------------------------------------------------------------------------------- + +newtype TrackerFeature s = TrackerFeature { unTrackerFeature :: ForeignPtr C'Ptr_TrackerFeature } +type instance C (TrackerFeature s) = C'Ptr_TrackerFeature + +instance WithPtr (TrackerFeature s) where + withPtr = withForeignPtr . unTrackerFeature + + +instance FromPtr (TrackerFeature s) where + fromPtr = objFromPtr TrackerFeature $ \ptr -> + [CU.block| void { + delete $(Ptr_TrackerFeature * ptr); + }|] + +newtype MultiTracker s = MultiTracker { unMultiTracker :: ForeignPtr C'Ptr_MultiTracker } +type instance C (MultiTracker s) = C'Ptr_MultiTracker + +instance WithPtr (MultiTracker s) where + withPtr = withForeignPtr . unMultiTracker + +instance FromPtr (MultiTracker s) where + fromPtr = objFromPtr MultiTracker $ \ptr -> + [CU.block| void { + delete $(Ptr_MultiTracker * ptr); + }|] + +newtype MultiTrackerAlt s = MultiTrackerAlt { unMultiTrackerAlt :: ForeignPtr C'Ptr_MultiTrackerAlt } +type instance C (MultiTrackerAlt s) = C'Ptr_MultiTrackerAlt + +instance WithPtr (MultiTrackerAlt s) where + withPtr = withForeignPtr . unMultiTrackerAlt + +instance FromPtr (MultiTrackerAlt s) where + fromPtr = objFromPtr MultiTrackerAlt $ \ptr -> + [CU.block| void { + delete $(Ptr_MultiTrackerAlt * ptr); + }|] + +-------------------------------------------------------------------------------- + +newMultiTracker + :: (PrimMonad m) + => TrackerType + -- ^ Name + -> m (MultiTracker (PrimState m)) +newMultiTracker trackerType = + unsafePrimToPrim $ fromPtr $ + withCString (show trackerType) $ \c'trackerType -> + [CU.block|Ptr_MultiTracker * { + cv::Ptr mtracker = + new cv::MultiTracker ( cv::String($(const char * c'trackerType))); + return new cv::Ptr(mtracker); + }|] + +-------------------------------------------------------------------------------- + +newTrackerFeature + :: (PrimMonad m) + => TrackerFeatureType + -- ^ Name + -> m (TrackerFeature (PrimState m)) +newTrackerFeature trackerFeatureType = + unsafePrimToPrim $ fromPtr $ + withCString (show trackerFeatureType) $ \c'trackerFeatureType -> + [CU.block|Ptr_TrackerFeature * { + cv::Ptr ftracker = + cv::TrackerFeature::create ( cv::String($(const char * c'trackerFeatureType))); + return new cv::Ptr(ftracker); + + }|] diff --git a/src/OpenCV/Extra/XFeatures2d.cpp b/src/OpenCV/Extra/XFeatures2d.cpp new file mode 100644 --- /dev/null +++ b/src/OpenCV/Extra/XFeatures2d.cpp @@ -0,0 +1,94 @@ + +#include "opencv2/core.hpp" + +#include "opencv2/xfeatures2d.hpp" + +#include "xfeatures/surf.hpp" + +using namespace cv; + +extern "C" { +Ptr_SURF * inline_c_OpenCV_Extra_XFeatures2d_0_bc51f58e60712bc5e3af0c96b0bc52ae5b9b1c1a(double chessianThreshold_27_inline_c_0, int32_t surf_nOctaves_inline_c_1, int32_t surf_nOctaveLayers_inline_c_2, bool cextended_27_inline_c_3, bool cupright_27_inline_c_4) { + + cv::Ptr surfPtr = + cv::xfeatures2d::SURF::create + ( chessianThreshold_27_inline_c_0 + , surf_nOctaves_inline_c_1 + , surf_nOctaveLayers_inline_c_2 + , cextended_27_inline_c_3 + , cupright_27_inline_c_4 + ); + return new cv::Ptr(surfPtr); + +} + +} + +extern "C" { +Exception * inline_c_OpenCV_Extra_XFeatures2d_1_010dc4a635b061c9b20e8bc1a0f09def3d5e993b(Ptr_SURF * surfPtr_inline_c_0, Mat * maskPtr_inline_c_1, Mat * imgPtr_inline_c_2, Mat * descPtr_inline_c_3, int32_t * numPtsPtr_inline_c_4, KeyPoint *** arrayPtrPtr_inline_c_5) { + + try + { + cv::xfeatures2d::SURF * surf = *surfPtr_inline_c_0; + cv::Mat * maskPtr = maskPtr_inline_c_1; + + std::vector keypoints = std::vector(); + surf-> + detectAndCompute + ( *imgPtr_inline_c_2 + , maskPtr ? cv::_InputArray(*maskPtr) : cv::_InputArray(noArray()) + , keypoints + , *descPtr_inline_c_3 + , false + ); + + *numPtsPtr_inline_c_4 = keypoints.size(); + + cv::KeyPoint * * * arrayPtrPtr = arrayPtrPtr_inline_c_5; + cv::KeyPoint * * arrayPtr = new cv::KeyPoint * [keypoints.size()]; + *arrayPtrPtr = arrayPtr; + + for (std::vector::size_type ix = 0; ix != keypoints.size(); ix++) + { + cv::KeyPoint & org = keypoints[ix]; + cv::KeyPoint * newPt = + new cv::KeyPoint( org.pt + , org.size + , org.angle + , org.response + , org.octave + , org.class_id + ); + arrayPtr[ix] = newPt; + } + + return NULL; + } + catch (const cv::Exception & e) + { + return new cv::Exception(e); + } + +} + +} + +extern "C" { +void inline_c_OpenCV_Extra_XFeatures2d_2_cf7ed8abd0aadc595f02b1ca9ec2ba13285a12cd(KeyPoint *** arrayPtrPtr_inline_c_0) { + + delete [] *arrayPtrPtr_inline_c_0; + +} + +} + +extern "C" { +void inline_c_OpenCV_Extra_XFeatures2d_3_0a78fb7b80501d1c0a37452b7758538729bc3810(Ptr_SURF * ptr_inline_c_0) { + + cv::Ptr * surf_ptr_ptr = ptr_inline_c_0; + surf_ptr_ptr->release(); + delete surf_ptr_ptr; + +} + +} diff --git a/src/OpenCV/Extra/XFeatures2d.hs b/src/OpenCV/Extra/XFeatures2d.hs new file mode 100644 --- /dev/null +++ b/src/OpenCV/Extra/XFeatures2d.hs @@ -0,0 +1,212 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} + +module OpenCV.Extra.XFeatures2d + ( -- * SURF + Surf + , SurfParams(..) + , defaultSurfParams + , mkSurf + , surfDetectAndCompute + + ) where + +import "base" Control.Exception ( mask_ ) +import "base" Data.Int +import "base" Data.Word +import "base" Foreign.ForeignPtr ( ForeignPtr, withForeignPtr ) +import "base" Foreign.Marshal.Alloc ( alloca ) +import "base" Foreign.Marshal.Array ( peekArray ) +import "base" Foreign.Marshal.Utils ( fromBool ) +import "base" Foreign.Ptr ( Ptr, nullPtr ) +import "base" Foreign.Storable ( peek ) +import "base" System.IO.Unsafe ( unsafePerformIO ) +import qualified "inline-c" Language.C.Inline as C +import qualified "inline-c" Language.C.Inline.Unsafe as CU +import qualified "inline-c-cpp" Language.C.Inline.Cpp as C +import "opencv" OpenCV.Core.Types +import "opencv" OpenCV.Internal +import "opencv" OpenCV.Internal.Core.Types.Mat +import "opencv" OpenCV.Internal.C.Types +import "opencv" OpenCV.Internal.Exception ( cvExcept, unsafeWrapException ) +import "opencv" OpenCV.TypeLevel +import "this" OpenCV.Extra.Internal.C.Inline ( openCvExtraCtx ) +import "this" OpenCV.Extra.Internal.C.Types +import qualified "vector" Data.Vector as V + +-------------------------------------------------------------------------------- + +C.context openCvExtraCtx + +C.include "opencv2/core.hpp" +C.include "opencv2/xfeatures2d.hpp" +C.include "xfeatures/surf.hpp" + +C.using "namespace cv" + +-------------------------------------------------------------------------------- +-- SURF - Speeded Up Roubst Features +-------------------------------------------------------------------------------- + +-- Internally, an Surf is a pointer to a @cv::Ptr@, which in turn points +-- to an actual @cv::xfeatures2d::SURF@ object. +newtype Surf = Surf {unSurf :: ForeignPtr C'Ptr_SURF} + +type instance C Surf = C'Ptr_SURF + +instance WithPtr Surf where + withPtr = withForeignPtr . unSurf + +instance FromPtr Surf where + fromPtr = objFromPtr Surf $ \ptr -> + [CU.block| void { + cv::Ptr * surf_ptr_ptr = $(Ptr_SURF * ptr); + surf_ptr_ptr->release(); + delete surf_ptr_ptr; + }|] + +-------------------------------------------------------------------------------- + +data SurfParams + = SurfParams + { surf_hessianThreshold :: !Double + -- ^ Threshold for hessian keypoint detector used in SURF + , surf_nOctaves :: !Int32 + -- ^ Number of pyramid octaves the keypoint detector will use. + , surf_nOctaveLayers :: !Int32 + -- ^ Number of octave layers within each octave. + , surf_extended :: !Bool + -- ^ Extended descriptor flag (true - use extended 128-element descriptors; false - use 64-element descriptors). + , surf_upright :: !Bool + -- ^ Up-right or rotated features flag (true - do not compute orientation of features; false - compute orientation). + } + +defaultSurfParams :: SurfParams +defaultSurfParams = + SurfParams + { surf_hessianThreshold = 100 + , surf_nOctaves = 4 + , surf_nOctaveLayers = 3 + , surf_extended = False + , surf_upright = False + } + +-------------------------------------------------------------------------------- + +newSurf :: SurfParams -> IO Surf +newSurf SurfParams{..} = fromPtr + [CU.block|Ptr_SURF * { + cv::Ptr surfPtr = + cv::xfeatures2d::SURF::create + ( $(double c'hessianThreshold) + , $(int32_t surf_nOctaves) + , $(int32_t surf_nOctaveLayers) + , $(bool c'extended) + , $(bool c'upright) + ); + return new cv::Ptr(surfPtr); + }|] + where + c'hessianThreshold = realToFrac surf_hessianThreshold + c'extended = fromBool surf_extended + c'upright = fromBool surf_upright + + +mkSurf :: SurfParams -> Surf +mkSurf = unsafePerformIO . newSurf + +-------------------------------------------------------------------------------- + +{- | Detect keypoints and compute descriptors + +Example: + +@ +surfDetectAndComputeImg + :: forall (width :: Nat) + (height :: Nat) + (channels :: Nat) + (depth :: *) + . (Mat (ShapeT [height, width]) ('S channels) ('S depth) ~ Frog) + => Mat (ShapeT [height, width]) ('S channels) ('S depth) +surfDetectAndComputeImg = exceptError $ do + (kpts, _descs) <- surfDetectAndCompute surf frog Nothing + withMatM (Proxy :: Proxy [height, width]) + (Proxy :: Proxy channels) + (Proxy :: Proxy depth) + white $ \\imgM -> do + void $ matCopyToM imgM (V2 0 0) frog Nothing + forM_ kpts $ \\kpt -> do + let kptRec = keyPointAsRec kpt + circle imgM (round \<$> kptPoint kptRec :: V2 Int32) 5 blue 1 LineType_AA 0 + where + surf = mkSurf defaultSurfParams +@ + +<> +-} +surfDetectAndCompute + :: Surf + -> Mat ('S [height, width]) channels depth -- ^ Image. + -> Maybe (Mat ('S [height, width]) ('S 1) ('S Word8)) -- ^ Mask. + -> CvExcept ( V.Vector KeyPoint + , Mat 'D 'D 'D + ) +surfDetectAndCompute surf img mbMask = unsafeWrapException $ do + descriptors <- newEmptyMat + withPtr surf $ \surfPtr -> + withPtr img $ \imgPtr -> + withPtr mbMask $ \maskPtr -> + withPtr descriptors $ \descPtr -> + alloca $ \(numPtsPtr :: Ptr Int32) -> + alloca $ \(arrayPtrPtr :: Ptr (Ptr (Ptr C'KeyPoint))) -> mask_ $ do + ptrException <- [cvExcept| + cv::xfeatures2d::SURF * surf = *$(Ptr_SURF * surfPtr); + cv::Mat * maskPtr = $(Mat * maskPtr); + + std::vector keypoints = std::vector(); + surf-> + detectAndCompute + ( *$(Mat * imgPtr) + , maskPtr ? cv::_InputArray(*maskPtr) : cv::_InputArray(noArray()) + , keypoints + , *$(Mat * descPtr) + , false + ); + + *$(int32_t * numPtsPtr) = keypoints.size(); + + cv::KeyPoint * * * arrayPtrPtr = $(KeyPoint * * * arrayPtrPtr); + cv::KeyPoint * * arrayPtr = new cv::KeyPoint * [keypoints.size()]; + *arrayPtrPtr = arrayPtr; + + for (std::vector::size_type ix = 0; ix != keypoints.size(); ix++) + { + cv::KeyPoint & org = keypoints[ix]; + cv::KeyPoint * newPt = + new cv::KeyPoint( org.pt + , org.size + , org.angle + , org.response + , org.octave + , org.class_id + ); + arrayPtr[ix] = newPt; + } + |] + if ptrException /= nullPtr + then Left . BindingException <$> fromPtr (pure ptrException) + else do + numPts <- fromIntegral <$> peek numPtsPtr + arrayPtr <- peek arrayPtrPtr + keypoints <- mapM (fromPtr . pure) =<< peekArray numPts arrayPtr + + [CU.block| void { + delete [] *$(KeyPoint * * * arrayPtrPtr); + }|] + + pure $ Right (V.fromList keypoints, relaxMat descriptors) + + +-- vim: ft=haskell diff --git a/src/OpenCV/Extra/XPhoto.cpp b/src/OpenCV/Extra/XPhoto.cpp new file mode 100644 --- /dev/null +++ b/src/OpenCV/Extra/XPhoto.cpp @@ -0,0 +1,28 @@ + +#include "opencv2/core.hpp" + +#include "opencv2/xphoto.hpp" + +using namespace cv; + +extern "C" { +Exception * inline_c_OpenCV_Extra_XPhoto_0_06297e612174af62db1078e41dba8535638659d5(Mat * srcPtr_inline_c_0, Mat * dstPtr_inline_c_1, double csigma_27_inline_c_2, int32_t cpSize_27_inline_c_3) { + + try + { + cv::xphoto::dctDenoising( *srcPtr_inline_c_0 + , *dstPtr_inline_c_1 + , csigma_27_inline_c_2 + , cpSize_27_inline_c_3 + ); + + return NULL; + } + catch (const cv::Exception & e) + { + return new cv::Exception(e); + } + +} + +} diff --git a/src/OpenCV/Extra/XPhoto.hs b/src/OpenCV/Extra/XPhoto.hs new file mode 100644 --- /dev/null +++ b/src/OpenCV/Extra/XPhoto.hs @@ -0,0 +1,80 @@ +{-# language CPP #-} +{-# language QuasiQuotes #-} +{-# language TemplateHaskell #-} + +#if __GLASGOW_HASKELL__ >= 800 +{-# options_ghc -Wno-redundant-constraints #-} +#endif + +module OpenCV.Extra.XPhoto + ( dctDenoising + ) where + +import "base" Data.Int ( Int32 ) +import "base" Data.Word ( Word8 ) +import "base" Data.Maybe ( fromMaybe ) +import qualified "inline-c" Language.C.Inline as C +import qualified "inline-c-cpp" Language.C.Inline.Cpp as C +import "opencv" OpenCV.Internal.C.Inline ( openCvCtx ) +import "opencv" OpenCV.Internal.C.Types ( withPtr ) +import "opencv" OpenCV.Internal.Exception +import "opencv" OpenCV.Internal.Core.Types.Mat +import "opencv" OpenCV.TypeLevel + +-------------------------------------------------------------------------------- + +C.context openCvCtx + +C.include "opencv2/core.hpp" +C.include "opencv2/xphoto.hpp" +C.using "namespace cv" + +{-| Perform dctDenoising function for colored images. + +Example: + +@ +dctDenoisingImg + :: forall h w w2 c d + . ( Mat (ShapeT [h, w]) ('S c) ('S d) ~ Lenna_512x512 + , w2 ~ ((*) w 2) + ) + => Mat ('S ['S h, 'S w2]) ('S c) ('S d) +dctDenoisingImg = exceptError $ do + denoised <- dctDenoising 10 Nothing lenna_512x512 + withMatM + (Proxy :: Proxy [h, w2]) + (Proxy :: Proxy c) + (Proxy :: Proxy d) + black $ \\imgM -> do + matCopyToM imgM (V2 0 0) lenna_512x512 Nothing + matCopyToM imgM (V2 w 0) denoised Nothing + where + w = fromInteger $ natVal (Proxy :: Proxy w) +@ + +<> +-} + +dctDenoising + :: Double -- ^ expected noise standard deviation + -> Maybe Int32 -- ^ size of block side where dct is computed use default 16 + -> Mat ('S [h, w]) ('S 3) ('S Word8) -- ^ Input image 8-bit 3-channel image. + -> CvExcept (Mat ('S [h, w]) ('S 3) ('S Word8)) + -- ^ Output image same size and type as input. +dctDenoising sigma mPSize src = + unsafeWrapException $ do + dst <- newEmptyMat + handleCvException (pure $ unsafeCoerceMat dst) $ + withPtr src $ \srcPtr -> + withPtr dst $ \dstPtr -> + [cvExcept| + cv::xphoto::dctDenoising( *$(Mat * srcPtr) + , *$(Mat * dstPtr) + , $(double c'sigma) + , $(int32_t c'pSize) + ); + |] + where + c'sigma = realToFrac sigma + c'pSize = fromMaybe 16 mPSize diff --git a/src/OpenCV/Extra/XPhoto/WhiteBalancer.cpp b/src/OpenCV/Extra/XPhoto/WhiteBalancer.cpp new file mode 100644 --- /dev/null +++ b/src/OpenCV/Extra/XPhoto/WhiteBalancer.cpp @@ -0,0 +1,182 @@ + +#include "opencv2/core.hpp" + +#include "opencv2/xphoto.hpp" + +#include "white-ballance.hpp" + +using namespace cv; + +extern "C" { +Ptr_GrayworldWB * inline_c_OpenCV_Extra_XPhoto_WhiteBalancer_0_4fd73c46202741401678ebad8803d1640b421482(double cvarThreshold_27_inline_c_0) { + + cv::Ptr wbAlg = cv::xphoto::createGrayworldWB (); + wbAlg->setSaturationThreshold(cvarThreshold_27_inline_c_0); + return new cv::Ptr(wbAlg); + +} + +} + +extern "C" { +Ptr_LearningBasedWB * inline_c_OpenCV_Extra_XPhoto_WhiteBalancer_1_0692032a7bec02f065f9e8e1c88aeec372b3efe9(int cvarHistBinNum_27_inline_c_0, int cvarRangeMaxVal_27_inline_c_1, double cvarSaturationThreshold_27_inline_c_2) { + + cv::Ptr wbAlg = cv::xphoto::createLearningBasedWB (); + wbAlg->setHistBinNum(cvarHistBinNum_27_inline_c_0); + wbAlg->setRangeMaxVal(cvarRangeMaxVal_27_inline_c_1); + wbAlg->setSaturationThreshold(cvarSaturationThreshold_27_inline_c_2); + return new cv::Ptr(wbAlg); + +} + +} + +extern "C" { +Ptr_SimpleWB * inline_c_OpenCV_Extra_XPhoto_WhiteBalancer_2_4ecea8417cf34021c3e52bee10fb9be4499827ea(double cvarIMin_27_inline_c_0, double cvarIMax_27_inline_c_1, double cvarOMin_27_inline_c_2, double cvarOMax_27_inline_c_3, double cvarP_27_inline_c_4) { + + cv::Ptr wbAlg = cv::xphoto::createSimpleWB (); + wbAlg->setInputMin( cvarIMin_27_inline_c_0); + wbAlg->setInputMax( cvarIMax_27_inline_c_1); + wbAlg->setOutputMin(cvarOMin_27_inline_c_2); + wbAlg->setOutputMax(cvarOMax_27_inline_c_3); + wbAlg->setP(cvarP_27_inline_c_4); + return new cv::Ptr(wbAlg); + +} + +} + +extern "C" { +void inline_c_OpenCV_Extra_XPhoto_WhiteBalancer_3_2378626bf54d7674c38c44cac881e7801e57d543(Ptr_SimpleWB * wbAlgPtr_inline_c_0, Mat * imgInPtr_inline_c_1, Mat * imgOutPtr_inline_c_2) { + + cv::xphoto::SimpleWB * wb = *wbAlgPtr_inline_c_0; + wb->balanceWhite + ( *imgInPtr_inline_c_1 + , *imgOutPtr_inline_c_2 + ); + +} + +} + +extern "C" { +void inline_c_OpenCV_Extra_XPhoto_WhiteBalancer_4_9c296a6aea62311d052959acbc63d86a7c62253b(Ptr_LearningBasedWB * wbAlgPtr_inline_c_0, Mat * imgInPtr_inline_c_1, Mat * imgOutPtr_inline_c_2) { + + cv::xphoto::LearningBasedWB * wb = *wbAlgPtr_inline_c_0; + wb->balanceWhite + ( *imgInPtr_inline_c_1 + , *imgOutPtr_inline_c_2 + ); + +} + +} + +extern "C" { +void inline_c_OpenCV_Extra_XPhoto_WhiteBalancer_5_80e5036bd319618f74258d98ddd7b0d8f641651b(Ptr_GrayworldWB * wbAlgPtr_inline_c_0, Mat * imgInPtr_inline_c_1, Mat * imgOutPtr_inline_c_2) { + + cv::xphoto::GrayworldWB * wb = *wbAlgPtr_inline_c_0; + wb->balanceWhite + ( *imgInPtr_inline_c_1 + , *imgOutPtr_inline_c_2 + ); + +} + +} + +extern "C" { +void inline_c_OpenCV_Extra_XPhoto_WhiteBalancer_6_3326c72a78f150bf51e4e5874c00ca2e9deed8ec(Ptr_SimpleWB * knnPtr_inline_c_0) { + + cv::xphoto::SimpleWB * knn = *knnPtr_inline_c_0; + knn->clear(); + +} + +} + +extern "C" { +void inline_c_OpenCV_Extra_XPhoto_WhiteBalancer_7_f5f092be98dedc30e21c12bd8c827d45feeeac9f(Ptr_SimpleWB * knnPtr_inline_c_0, bool * emptyPtr_inline_c_1) { + + cv::xphoto::SimpleWB * knn = *knnPtr_inline_c_0; + *emptyPtr_inline_c_1 = knn->empty(); + +} + +} + +extern "C" { +void inline_c_OpenCV_Extra_XPhoto_WhiteBalancer_8_8d9092fd1aec4fa0c8ea6ce464757e5b4a90738f(Ptr_LearningBasedWB * knnPtr_inline_c_0) { + + cv::xphoto::LearningBasedWB * knn = *knnPtr_inline_c_0; + knn->clear(); + +} + +} + +extern "C" { +void inline_c_OpenCV_Extra_XPhoto_WhiteBalancer_9_fb6d5b983e28c8b8df2c941c172abb66b3802cea(Ptr_LearningBasedWB * knnPtr_inline_c_0, bool * emptyPtr_inline_c_1) { + + cv::xphoto::LearningBasedWB * knn = *knnPtr_inline_c_0; + *emptyPtr_inline_c_1 = knn->empty(); + +} + +} + +extern "C" { +void inline_c_OpenCV_Extra_XPhoto_WhiteBalancer_10_c7381c418d45bf665351fc19c11208bbda9dff4f(Ptr_GrayworldWB * knnPtr_inline_c_0) { + + cv::xphoto::GrayworldWB * knn = *knnPtr_inline_c_0; + knn->clear(); + +} + +} + +extern "C" { +void inline_c_OpenCV_Extra_XPhoto_WhiteBalancer_11_d692009848de0a973eeb08ab410c913952046b11(Ptr_GrayworldWB * knnPtr_inline_c_0, bool * emptyPtr_inline_c_1) { + + cv::xphoto::GrayworldWB * knn = *knnPtr_inline_c_0; + *emptyPtr_inline_c_1 = knn->empty(); + +} + +} + +extern "C" { +void inline_c_OpenCV_Extra_XPhoto_WhiteBalancer_12_97c5d79b5414aedba9c9d3333bfc0d26531e5bdb(Ptr_SimpleWB * ptr_inline_c_0) { + + cv::Ptr * knn_ptr_ptr = + ptr_inline_c_0; + knn_ptr_ptr->release(); + delete knn_ptr_ptr; + +} + +} + +extern "C" { +void inline_c_OpenCV_Extra_XPhoto_WhiteBalancer_13_680790a74227e4ede15c2bb1a2657d8b4e6969eb(Ptr_LearningBasedWB * ptr_inline_c_0) { + + cv::Ptr * knn_ptr_ptr = + ptr_inline_c_0; + knn_ptr_ptr->release(); + delete knn_ptr_ptr; + +} + +} + +extern "C" { +void inline_c_OpenCV_Extra_XPhoto_WhiteBalancer_14_1ec8441459880af3f8a2cb39d16f08188b544e0e(Ptr_GrayworldWB * ptr_inline_c_0) { + + cv::Ptr * knn_ptr_ptr = + ptr_inline_c_0; + knn_ptr_ptr->release(); + delete knn_ptr_ptr; + +} + +} diff --git a/src/OpenCV/Extra/XPhoto/WhiteBalancer.hs b/src/OpenCV/Extra/XPhoto/WhiteBalancer.hs new file mode 100644 --- /dev/null +++ b/src/OpenCV/Extra/XPhoto/WhiteBalancer.hs @@ -0,0 +1,312 @@ +{-# language TemplateHaskell #-} +{-# language QuasiQuotes #-} + +module OpenCV.Extra.XPhoto.WhiteBalancer + ( WhiteBalancer (..) + , GrayworldWB + , LearningBasedWB + , SimpleWB + , newGrayworldWB + , newLearningBasedWB + , newSimpleWB + ) where + +import "base" Data.Int +import "base" Foreign.ForeignPtr ( ForeignPtr, withForeignPtr ) +import "base" Foreign.Marshal.Alloc ( alloca ) +import "base" Foreign.Marshal.Utils ( toBool ) +import "base" Foreign.Storable ( peek ) +import qualified "inline-c" Language.C.Inline as C +import qualified "inline-c" Language.C.Inline.Unsafe as CU +import qualified "inline-c-cpp" Language.C.Inline.Cpp as C +import "opencv" OpenCV.Core.Types +import "opencv" OpenCV.Internal +import "opencv" OpenCV.Internal.Core.Types.Mat +import "opencv" OpenCV.Internal.C.Types +-- import "opencv" OpenCV.Video.MotionAnalysis ( BackgroundSubtractor(..) ) +import "primitive" Control.Monad.Primitive +import "this" OpenCV.Extra.Internal.C.Inline ( openCvExtraCtx ) +import "this" OpenCV.Extra.Internal.C.Types +import "opencv" OpenCV.TypeLevel + +C.context openCvExtraCtx + +C.include "opencv2/core.hpp" +C.include "opencv2/xphoto.hpp" +C.include "white-ballance.hpp" + +C.using "namespace cv" + +-------------------------------------------------------------------------------- +-- WhiteBalancer +-------------------------------------------------------------------------------- + +class WhiteBalancer a where + balanceWhite + :: (PrimMonad m) + => a (PrimState m) + -> Mat ('S [h, w]) channels depth -- ^ The input Image. + -> m (Mat ('S [h, w]) channels depth) -- ^ The output image. + +-------------------------------------------------------------------------------- +-- Background subtractors +-------------------------------------------------------------------------------- + +newtype GrayworldWB s + = GrayworldWB + { unGrayworldWB :: ForeignPtr C'Ptr_GrayworldWB } + +type instance C (GrayworldWB s) = C'Ptr_GrayworldWB + +instance WithPtr (GrayworldWB s) where + withPtr = withForeignPtr . unGrayworldWB + +instance FromPtr (GrayworldWB s) where + fromPtr = objFromPtr GrayworldWB $ \ptr -> + [CU.block| void { + cv::Ptr * knn_ptr_ptr = + $(Ptr_GrayworldWB * ptr); + knn_ptr_ptr->release(); + delete knn_ptr_ptr; + }|] + +newtype LearningBasedWB s + = LearningBasedWB + { unLearningBasedWB :: ForeignPtr C'Ptr_LearningBasedWB } + +type instance C (LearningBasedWB s) = C'Ptr_LearningBasedWB + +instance WithPtr (LearningBasedWB s) where + withPtr = withForeignPtr . unLearningBasedWB + +instance FromPtr (LearningBasedWB s) where + fromPtr = objFromPtr LearningBasedWB $ \ptr -> + [CU.block| void { + cv::Ptr * knn_ptr_ptr = + $(Ptr_LearningBasedWB * ptr); + knn_ptr_ptr->release(); + delete knn_ptr_ptr; + }|] + +newtype SimpleWB s + = SimpleWB + { unSimpleWB :: ForeignPtr C'Ptr_SimpleWB } + +type instance C (SimpleWB s) = C'Ptr_SimpleWB + +instance WithPtr (SimpleWB s) where + withPtr = withForeignPtr . unSimpleWB + +instance FromPtr (SimpleWB s) where + fromPtr = objFromPtr SimpleWB $ \ptr -> + [CU.block| void { + cv::Ptr * knn_ptr_ptr = + $(Ptr_SimpleWB * ptr); + knn_ptr_ptr->release(); + delete knn_ptr_ptr; + }|] + +--- +instance Algorithm GrayworldWB where + algorithmClearState knn = unsafePrimToPrim $ + withPtr knn $ \knnPtr -> + [C.block|void { + cv::xphoto::GrayworldWB * knn = *$(Ptr_GrayworldWB * knnPtr); + knn->clear(); + }|] + + algorithmIsEmpty knn = unsafePrimToPrim $ + withPtr knn $ \knnPtr -> + alloca $ \emptyPtr -> do + [C.block|void { + cv::xphoto::GrayworldWB * knn = *$(Ptr_GrayworldWB * knnPtr); + *$(bool * emptyPtr) = knn->empty(); + }|] + toBool <$> peek emptyPtr + +instance Algorithm LearningBasedWB where + algorithmClearState knn = unsafePrimToPrim $ + withPtr knn $ \knnPtr -> + [C.block|void { + cv::xphoto::LearningBasedWB * knn = *$(Ptr_LearningBasedWB * knnPtr); + knn->clear(); + }|] + + algorithmIsEmpty knn = unsafePrimToPrim $ + withPtr knn $ \knnPtr -> + alloca $ \emptyPtr -> do + [C.block|void { + cv::xphoto::LearningBasedWB * knn = *$(Ptr_LearningBasedWB * knnPtr); + *$(bool * emptyPtr) = knn->empty(); + }|] + toBool <$> peek emptyPtr + +instance Algorithm SimpleWB where + algorithmClearState knn = unsafePrimToPrim $ + withPtr knn $ \knnPtr -> + [C.block|void { + cv::xphoto::SimpleWB * knn = *$(Ptr_SimpleWB * knnPtr); + knn->clear(); + }|] + + algorithmIsEmpty knn = unsafePrimToPrim $ + withPtr knn $ \knnPtr -> + alloca $ \emptyPtr -> do + [C.block|void { + cv::xphoto::SimpleWB * knn = *$(Ptr_SimpleWB * knnPtr); + *$(bool * emptyPtr) = knn->empty(); + }|] + toBool <$> peek emptyPtr +--- + +instance WhiteBalancer GrayworldWB where + balanceWhite wbAlg imgIn = unsafePrimToPrim $ do + imgOut <- newEmptyMat + withPtr wbAlg $ \wbAlgPtr -> + withPtr imgIn $ \imgInPtr -> + withPtr imgOut $ \imgOutPtr -> do + [C.block| void { + cv::xphoto::GrayworldWB * wb = *$(Ptr_GrayworldWB * wbAlgPtr); + wb->balanceWhite + ( *$(Mat * imgInPtr) + , *$(Mat * imgOutPtr) + ); + }|] + pure $ unsafeCoerceMat imgOut + +instance WhiteBalancer LearningBasedWB where + balanceWhite wbAlg imgIn = unsafePrimToPrim $ do + imgOut <- newEmptyMat + withPtr wbAlg $ \wbAlgPtr -> + withPtr imgIn $ \imgInPtr -> + withPtr imgOut $ \imgOutPtr -> do + [C.block| void { + cv::xphoto::LearningBasedWB * wb = *$(Ptr_LearningBasedWB * wbAlgPtr); + wb->balanceWhite + ( *$(Mat * imgInPtr) + , *$(Mat * imgOutPtr) + ); + }|] + pure $ unsafeCoerceMat imgOut + +instance WhiteBalancer SimpleWB where + balanceWhite wbAlg imgIn = unsafePrimToPrim $ do + imgOut <- newEmptyMat + withPtr wbAlg $ \wbAlgPtr -> + withPtr imgIn $ \imgInPtr -> + withPtr imgOut $ \imgOutPtr -> do + [C.block| void { + cv::xphoto::SimpleWB * wb = *$(Ptr_SimpleWB * wbAlgPtr); + wb->balanceWhite + ( *$(Mat * imgInPtr) + , *$(Mat * imgOutPtr) + ); + }|] + pure $ unsafeCoerceMat imgOut +--- + +{-| Perform GrayworldWB a simple grayworld white balance algorithm. + +Example: + +@ +grayworldWBImg + :: forall h w h2 w2 c d + . ( Mat (ShapeT [h, w]) ('S c) ('S d) ~ Sailboat_768x512 + , w2 ~ ((*) w 2) + , h2 ~ ((*) h 2) + ) + => IO (Mat ('S ['S h2, 'S w2]) ('S c) ('S d)) +grayworldWBImg = do + let + bw :: (WhiteBalancer a) => a (PrimState IO) -> IO (Mat (ShapeT [h, w]) ('S c) ('S d)) + bw = flip balanceWhite sailboat_768x512 + balancedGrayworldWB <- bw =<< newGrayworldWB Nothing + balancedLearningBasedWB <- bw =<< newLearningBasedWB Nothing Nothing Nothing + balancedSimpleWB <- bw =<< newSimpleWB Nothing Nothing Nothing Nothing Nothing + pure $ exceptError $ + withMatM + (Proxy :: Proxy [h2, w2]) + (Proxy :: Proxy c) + (Proxy :: Proxy d) + black $ \\imgM -> do + matCopyToM imgM (V2 0 0) sailboat_768x512 Nothing + matCopyToM imgM (V2 w 0) balancedGrayworldWB Nothing + matCopyToM imgM (V2 0 h) balancedLearningBasedWB Nothing + matCopyToM imgM (V2 w h) balancedSimpleWB Nothing + where + w = fromInteger $ natVal (Proxy :: Proxy w) + h = fromInteger $ natVal (Proxy :: Proxy h) +@ + +<> + +-} + +newGrayworldWB + :: (PrimMonad m) + => Maybe Double + -- ^ A threshold of 1 means that all pixels are used to white-balance, + -- while a threshold of 0 means no pixels are used. Lower thresholds + -- are useful in white-balancing saturated images. Default: 0.9. + -> m (GrayworldWB (PrimState m)) +newGrayworldWB mbVarThreshold = unsafePrimToPrim $ fromPtr + [CU.block|Ptr_GrayworldWB * { + cv::Ptr wbAlg = cv::xphoto::createGrayworldWB (); + wbAlg->setSaturationThreshold($(double c'varThreshold )); + return new cv::Ptr(wbAlg); + }|] + where + c'varThreshold = maybe 0.9 realToFrac mbVarThreshold + +newLearningBasedWB + :: (PrimMonad m) + => Maybe Int32 + -- ^ default 64, Defines the size of one dimension of a + -- three-dimensional RGB histogram that is used internally by the algorithm. + -- It often makes sense to increase the number of bins for images with + -- higher bit depth (e.g. 256 bins for a 12 bit image). + -> Maybe Int32 + -- ^ default 255, Maximum possible value of the input image (e.g. 255 for 8 bit images, 4095 for 12 bit images) + -> Maybe Double + -- ^ default 0.98, Threshold that is used to determine saturated pixels, + -- i.e. pixels where at least one of the channels exceeds + -> m (LearningBasedWB (PrimState m)) +newLearningBasedWB mbVarHistBinNum mbRangeMaxVal mbVarSaturationThreshold + = unsafePrimToPrim $ fromPtr + [CU.block|Ptr_LearningBasedWB * { + cv::Ptr wbAlg = cv::xphoto::createLearningBasedWB (); + wbAlg->setHistBinNum($(int c'varHistBinNum )); + wbAlg->setRangeMaxVal($(int c'varRangeMaxVal )); + wbAlg->setSaturationThreshold($(double c'varSaturationThreshold )); + return new cv::Ptr(wbAlg); + }|] + where + c'varHistBinNum = maybe 64 fromIntegral mbVarHistBinNum + c'varRangeMaxVal = maybe 255 fromIntegral mbRangeMaxVal + c'varSaturationThreshold = maybe 0.98 realToFrac mbVarSaturationThreshold + +newSimpleWB + :: (PrimMonad m) + => Maybe Double -- ^ Input Min (default: 0) + -> Maybe Double -- ^ Input Max (default: 255) + -> Maybe Double -- ^ Output Min (default: 0) + -> Maybe Double -- ^ Output Max (default: 255) + -> Maybe Double -- ^ Percent of top/bottom values to ignore (default: 2) + -> m (SimpleWB (PrimState m)) +newSimpleWB mbIMin mbIMax mbOMin mbOMax mbP = unsafePrimToPrim $ fromPtr + [CU.block|Ptr_SimpleWB * { + cv::Ptr wbAlg = cv::xphoto::createSimpleWB (); + wbAlg->setInputMin( $(double c'varIMin )); + wbAlg->setInputMax( $(double c'varIMax )); + wbAlg->setOutputMin($(double c'varOMin )); + wbAlg->setOutputMax($(double c'varOMax )); + wbAlg->setP($(double c'varP )); + return new cv::Ptr(wbAlg); + }|] + where + c'varIMin = maybe 0 realToFrac mbIMin + c'varIMax = maybe 255 realToFrac mbIMax + c'varOMin = maybe 0 realToFrac mbOMin + c'varOMax = maybe 255 realToFrac mbOMax + c'varP = maybe 2 realToFrac mbP