module Theora.Encoding (
Info(..),Comment (..),
PixelFmt(Pf420,Pf422,Pf444),ColorSpace(..),
encodeAlloc,
flushHeader,
ImgPlane,
YCbCrBuffer(..),newYCbCr,
encodeIn, encodeOut,
OggPacket,newOggStreamState,
OggPage,streamPacketIn, streamPageOut, streamFlush) where
import Foreign.Storable
import Foreign
import Foreign.ForeignPtr
import Foreign.C.Types
import Foreign.C.String
import Data.Int
data PixelFmt=
Pf420
| PfRsvd
| Pf422
| Pf444
instance Enum PixelFmt where
fromEnum Pf420= 0
fromEnum PfRsvd= 1
fromEnum Pf422= 2
fromEnum Pf444= 3
toEnum (0)=Pf420
toEnum (1)=PfRsvd
toEnum (2)=Pf422
toEnum (3)=Pf444
data ColorSpace=
Unspecified
|ItuRec470M
|ItuRec470BG
instance Enum ColorSpace where
fromEnum Unspecified = 0
fromEnum ItuRec470M = 1
fromEnum ItuRec470BG = 2
toEnum (0)=Unspecified
toEnum (1)=ItuRec470M
toEnum (2)=ItuRec470BG
data Info=Info {frameWidth::Int32,
frameHeight::Int32,
picWidth::Int32,
picHeight::Int32,
picX::Int32,
picY::Int32,
colorSpace::ColorSpace,
pixelFmt::PixelFmt,
targetBitRate::CInt,
quality::CInt,
keyframeGranuleShift::CInt}
efault= 1
instance Storable Info where
sizeOf _ = (64)
alignment _=1
peek ptr = do
fw<-((\hsc_ptr -> peekByteOff hsc_ptr 4)) ptr
fh<-((\hsc_ptr -> peekByteOff hsc_ptr 8)) ptr
pw<-((\hsc_ptr -> peekByteOff hsc_ptr 12)) ptr
ph<-((\hsc_ptr -> peekByteOff hsc_ptr 12)) ptr
px<-((\hsc_ptr -> peekByteOff hsc_ptr 20)) ptr
py<-((\hsc_ptr -> peekByteOff hsc_ptr 24)) ptr
cspace<-((\hsc_ptr -> peekByteOff hsc_ptr 44)) ptr
pfmt<-((\hsc_ptr -> peekByteOff hsc_ptr 48)) ptr
brate<-((\hsc_ptr -> peekByteOff hsc_ptr 52)) ptr
qual<-((\hsc_ptr -> peekByteOff hsc_ptr 56)) ptr
kframe<-((\hsc_ptr -> peekByteOff hsc_ptr 60)) ptr
return Info {frameWidth=fw,
frameHeight=fh,
picWidth=pw,
picHeight=ph,
picX=px,
picY=py,
colorSpace=toEnum cspace,
pixelFmt=toEnum pfmt,
targetBitRate=brate,
quality=qual,
keyframeGranuleShift=kframe}
poke ptr (Info fw fh pw ph px py cspace pfmt brate qual kframe)=do
((\hsc_ptr -> pokeByteOff hsc_ptr 4)) ptr fw
((\hsc_ptr -> pokeByteOff hsc_ptr 8)) ptr fh
((\hsc_ptr -> pokeByteOff hsc_ptr 12)) ptr pw
((\hsc_ptr -> pokeByteOff hsc_ptr 16)) ptr ph
((\hsc_ptr -> pokeByteOff hsc_ptr 20)) ptr px
((\hsc_ptr -> pokeByteOff hsc_ptr 24)) ptr py
((\hsc_ptr -> pokeByteOff hsc_ptr 44)) ptr $ fromEnum cspace
((\hsc_ptr -> pokeByteOff hsc_ptr 48)) ptr $ fromEnum pfmt
((\hsc_ptr -> pokeByteOff hsc_ptr 52)) ptr brate
((\hsc_ptr -> pokeByteOff hsc_ptr 56)) ptr qual
((\hsc_ptr -> pokeByteOff hsc_ptr 60)) ptr kframe
data OggPacket=Packet {packet::Ptr CChar,
bytes::CLong,
bos::CLong,
eos::CLong,
granulePos::Int64,
packetNo::Int64}
instance Storable OggPacket where
sizeOf _= (32)
alignment _=1
peek ptr=do
packet<-((\hsc_ptr -> peekByteOff hsc_ptr 0)) ptr
bytes<-((\hsc_ptr -> peekByteOff hsc_ptr 4)) ptr
bos<-((\hsc_ptr -> peekByteOff hsc_ptr 8)) ptr
eos<-((\hsc_ptr -> peekByteOff hsc_ptr 12)) ptr
granulePos<-((\hsc_ptr -> peekByteOff hsc_ptr 16)) ptr
packetNo<-((\hsc_ptr -> peekByteOff hsc_ptr 24)) ptr
return $ Packet {packet=packet,
bytes=bytes,
bos=bos,
eos=eos,
granulePos=granulePos,
packetNo=packetNo}
poke ptr (Packet pack bytes bos eos gpos pno)=do
((\hsc_ptr -> pokeByteOff hsc_ptr 0)) ptr pack
((\hsc_ptr -> pokeByteOff hsc_ptr 4)) ptr bytes
((\hsc_ptr -> pokeByteOff hsc_ptr 8)) ptr bos
((\hsc_ptr -> pokeByteOff hsc_ptr 12)) ptr eos
((\hsc_ptr -> pokeByteOff hsc_ptr 16)) ptr gpos
((\hsc_ptr -> pokeByteOff hsc_ptr 24)) ptr pno
data ThEncCtx
type EncCtx=ForeignPtr ThEncCtx
foreign import ccall "theora/theora.h th_encode_alloc" th_encode_alloc::(Ptr Info)->IO (Ptr ThEncCtx)
foreign import ccall "theora/theora.h th_info_init" th_info_init::(Ptr Info)->IO ()
foreign import ccall "theora/theora.h &th_encode_free" th_encode_free::FunPtr ((Ptr ThEncCtx)->IO())
encodeAlloc::Info->IO (Maybe EncCtx)
encodeAlloc inf=do
ptr<-alloca (\i->do
th_info_init i
poke i inf
th_encode_alloc i)
if ptr==nullPtr then return Nothing else
newForeignPtr th_encode_free ptr >>= (return.Just)
data Comment=Comment {
user::[String],
vendor::String
}
instance Storable Comment where
sizeOf _ = (16)
alignment _=1
peek ptr=do
length<- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) ptr
c_userComments<-peekArray length =<< ((\hsc_ptr -> peekByteOff hsc_ptr 8)) ptr
userComments<-mapM (peekCString) c_userComments
vendor<-((\hsc_ptr -> peekByteOff hsc_ptr 12)) ptr >>= peekCString
return $Comment {user=userComments,
vendor=vendor}
poke ptr comment= do
userComments<-mallocArray (length $ user comment)
cstrings<-mapM (\str->newCString str) $user comment
pokeArray userComments cstrings
((\hsc_ptr -> pokeByteOff hsc_ptr 0)) ptr userComments
commentLengths<-mallocArray (length $ user comment)
pokeArray commentLengths (map length $ user comment)
((\hsc_ptr -> pokeByteOff hsc_ptr 4)) ptr commentLengths
((\hsc_ptr -> pokeByteOff hsc_ptr 8)) ptr (length $ user comment)
((\hsc_ptr -> pokeByteOff hsc_ptr 12)) ptr =<< (newCString $ vendor comment)
data HeaderPacket=HeaderPacket
foreign import ccall "theora/theora.h th_comment_init" th_comment_init::Ptr Comment->IO()
foreign import ccall "theora/theora.h th_encode_flushheader" th_encode_flushheader::
(Ptr ThEncCtx)->(Ptr Comment)->(Ptr OggPacket)->IO CInt
flushHeader::EncCtx->Comment->IO [OggPacket]
flushHeader enc comment=
withForeignPtr enc (\encctx->
alloca (\ogg->
alloca (\pComment->
do
th_comment_init pComment
poke pComment comment
ret<-th_encode_flushheader encctx pComment ogg
if ret==0 || ret==efault then return [] else
do
tl<-flushHeader enc comment
peek ogg >>= return.(:tl))))
data ImgPlane=ImgPlane {width::CInt,
height::CInt,
stride::CInt,
img::ForeignPtr CUChar}
instance Storable ImgPlane where
sizeOf _= (16)
alignment _=1
peek ptr=do
width<-((\hsc_ptr -> peekByteOff hsc_ptr 0)) ptr
height<-((\hsc_ptr -> peekByteOff hsc_ptr 4)) ptr
stride<-((\hsc_ptr -> peekByteOff hsc_ptr 8)) ptr
img<-(((\hsc_ptr -> peekByteOff hsc_ptr 12)) ptr) >>= newForeignPtr finalizerFree
return $ ImgPlane {width=width,
height=height,
stride=stride,
img=img}
poke ptr (ImgPlane w h s i)=do
((\hsc_ptr -> pokeByteOff hsc_ptr 0)) ptr w
((\hsc_ptr -> pokeByteOff hsc_ptr 4)) ptr h
((\hsc_ptr -> pokeByteOff hsc_ptr 8)) ptr s
withForeignPtr i (\img->((\hsc_ptr -> pokeByteOff hsc_ptr 12)) ptr img)
foreign import ccall "theora/theora.h th_encode_ycbcr_in" th_encode_ycbcr_in::
(Ptr ThEncCtx)->(Ptr YCbCrBuffer)->IO CInt
data YCbCrBuffer=YCbCr {
y ::ImgPlane,
cb::ImgPlane,
cr::ImgPlane
}
instance Storable YCbCrBuffer where
sizeOf _= (48)
alignment _= sizeOf (undefined :: Ptr ImgPlane)
peek imgPtr=do
let ptr=castPtr imgPtr
y<-peek ptr
cb<-peek (ptr`plusPtr`(sizeOf (undefined :: ImgPlane)))
cr<-peek (ptr`plusPtr`(2*(sizeOf (undefined :: ImgPlane))))
return $ YCbCr {y=y,
cb=cb,
cr=cr}
poke imgPtr (YCbCr y cb cr)=do
let ptr=castPtr imgPtr
poke ptr y
poke (ptr`plusPtr`(sizeOf (undefined::ImgPlane))) cb
poke (ptr`plusPtr`(2*(sizeOf (undefined::ImgPlane)))) cr
newYCbCr::Int->Int->PixelFmt->IO YCbCrBuffer
newYCbCr wH hH Pf420=do
yImg<-newForeignPtr finalizerFree =<< (mallocBytes $ wH*hH)
cbImg<-newForeignPtr finalizerFree =<< (mallocBytes $ (wH*hH)`quot`4)
crImg<-newForeignPtr finalizerFree =<< (mallocBytes $ (wH*hH)`quot`4)
let w=(fromIntegral wH)`quot`2
h=(fromIntegral hH)`quot`2
y=ImgPlane {width=fromIntegral wH,
height=fromIntegral hH,
stride=w,
img=yImg}
cb=ImgPlane{width=w,
height=h,
stride=w,
img=cbImg}
cr=ImgPlane{width=w,
height=h,
stride=w,
img=crImg}
return $ YCbCr {y=y,cb=cb,cr=cr}
encodeIn::EncCtx->YCbCrBuffer->IO()
encodeIn enc buf=
withForeignPtr enc (\enc->alloca (\pbuf->do
poke pbuf buf
ret<-th_encode_ycbcr_in enc pbuf
return ()))
foreign import ccall "theora/theora.h th_encode_packetout" th_encode_packetout::
Ptr ThEncCtx->CInt->Ptr OggPacket->IO CInt
encodeOut::EncCtx->Bool->IO [OggPacket]
encodeOut e last=
withForeignPtr e (\enc->
alloca (\packet->do
res<-th_encode_packetout enc (if last then 1 else 0) packet
if res==0 || res==efault then return [] else do
tl<-encodeOut e last
peek packet >>= (return.(:tl))))
data OggPage=OggPage{header::Ptr CChar,
headerLen::CLong,
body::Ptr CChar,
bodyLen::CLong}
instance Storable OggPage where
sizeOf _= (16)
alignment _=1
peek ptr=do
header<-((\hsc_ptr -> peekByteOff hsc_ptr 0)) ptr
headerLen<-((\hsc_ptr -> peekByteOff hsc_ptr 4)) ptr
body<-((\hsc_ptr -> peekByteOff hsc_ptr 8)) ptr
bodyLen<-((\hsc_ptr -> peekByteOff hsc_ptr 12)) ptr
return $ OggPage{header=header, headerLen=headerLen, body=body, bodyLen=bodyLen}
poke ptr x=do
((\hsc_ptr -> pokeByteOff hsc_ptr 0)) ptr (header x)
((\hsc_ptr -> pokeByteOff hsc_ptr 4)) ptr (headerLen x)
((\hsc_ptr -> pokeByteOff hsc_ptr 8)) ptr $ body x
((\hsc_ptr -> pokeByteOff hsc_ptr 12)) ptr $ bodyLen x
instance Show OggPage where
show (OggPage hdr hdrl body bodyl)=
unsafePerformIO (do
head<-peekCStringLen (hdr,fromIntegral hdrl)
body<-peekCStringLen (body,fromIntegral bodyl)
return $ head++body)
data COggStreamState
type OggStreamState=ForeignPtr COggStreamState
instance Storable COggStreamState where
sizeOf _= (360)
alignment _=1
foreign import ccall "theora/theora.h ogg_stream_init" ogg_stream_init::
(Ptr COggStreamState)->CInt->IO CInt
foreign import ccall "theora/theora.h ogg_stream_packetin" ogg_stream_packetin::
(Ptr COggStreamState)->(Ptr OggPacket)->IO CInt
foreign import ccall "theora/theora.h ogg_stream_pageout" ogg_stream_pageout::
(Ptr COggStreamState)->(Ptr OggPage)->IO CInt
foreign import ccall "theora/theora.h ogg_stream_flush" ogg_stream_flush::
(Ptr COggStreamState)->(Ptr OggPage)->IO CInt
newOggStreamState::Int->IO OggStreamState
newOggStreamState initial=do
state<-malloc
success<-ogg_stream_init state $ fromIntegral initial
newForeignPtr finalizerFree state
streamPacketIn::OggStreamState->OggPacket->IO ()
streamPacketIn state packet=
withForeignPtr state (\s->
alloca(\pack->do
poke pack packet
ogg_stream_packetin s pack
return ()))
streamPageOut::OggStreamState->IO (Maybe OggPage)
streamPageOut state=
withForeignPtr state (\s->
alloca(\page->do
result<-ogg_stream_pageout s page
if result==0 then return Nothing else
peek page >>= return.Just))
streamFlush::OggStreamState->IO (Maybe OggPage)
streamFlush state=
withForeignPtr state (\s->
alloca (\page->do
res<-ogg_stream_flush s page
if res==0 then return Nothing else
peek page >>= (return.Just) ))