{-#LANGUAGE ForeignFunctionInterface #-} {-#OPTIONS -fglasgow-exts -logg -ltheora #-} -- | This module calls the libtheora C library to generate video ogg files from YCbCr images. -- As explained on , the basic steps -- for creating a video are the following : -- -- * create in an 'Info' record -- -- * call 'encodeAlloc' on it -- -- * call 'flushHeader' until it returns 'Nothing' -- -- * For each uncompressed frame, submit it with 'encodeIn', then retrieve potential packets -- with 'encodeOut' module Theora.Encoding (-- * Theora structures and function Info(..),Comment (..), PixelFmt(Pf420,Pf422,Pf444),ColorSpace(..), encodeAlloc, flushHeader, ImgPlane, YCbCrBuffer(..),newYCbCr, encodeIn, encodeOut, -- * Ogg-related functions 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 #include #include {-| Theora supports 4 different pixel formats, listed in . YCbCr chroma frames (Cb and Cr) may be resized for compression (see ). The resulting pixel formats are as follows : -} data PixelFmt= Pf420 -- ^Chroma decimation by 2 in both directions | PfRsvd | Pf422 -- ^Chroma decimation by 2 in the /x/ direction | Pf444 -- ^No chroma decimation instance Enum PixelFmt where fromEnum Pf420= #const TH_PF_420 fromEnum PfRsvd= #const TH_PF_RSVD fromEnum Pf422= #const TH_PF_422 fromEnum Pf444= #const TH_PF_444 toEnum (#const TH_PF_420)=Pf420 toEnum (#const TH_PF_RSVD)=PfRsvd toEnum (#const TH_PF_422)=Pf422 toEnum (#const TH_PF_444)=Pf444 data ColorSpace= Unspecified |ItuRec470M -- ^A color space designed for NTSC content |ItuRec470BG -- ^A color space designed for PAL/SECAM content instance Enum ColorSpace where fromEnum Unspecified = #const TH_CS_UNSPECIFIED fromEnum ItuRec470M = #const TH_CS_ITU_REC_470M fromEnum ItuRec470BG = #const TH_CS_ITU_REC_470BG toEnum (#const TH_CS_UNSPECIFIED)=Unspecified toEnum (#const TH_CS_ITU_REC_470M)=ItuRec470M toEnum (#const TH_CS_ITU_REC_470BG)=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= #const TH_EFAULT instance Storable Info where sizeOf _ = #size th_info alignment _=1 peek ptr = do fw<-(#peek th_info, frame_width) ptr fh<-(#peek th_info, frame_height) ptr pw<-(#peek th_info, pic_width) ptr ph<-(#peek th_info, pic_width) ptr px<-(#peek th_info, pic_x) ptr py<-(#peek th_info, pic_y) ptr cspace<-(#peek th_info, colorspace) ptr pfmt<-(#peek th_info, pixel_fmt) ptr brate<-(#peek th_info, target_bitrate) ptr qual<-(#peek th_info, quality) ptr kframe<-(#peek th_info, keyframe_granule_shift) 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 (#poke th_info, frame_width) ptr fw (#poke th_info, frame_height) ptr fh (#poke th_info, pic_width) ptr pw (#poke th_info, pic_height) ptr ph (#poke th_info, pic_x) ptr px (#poke th_info, pic_y) ptr py (#poke th_info, colorspace) ptr $ fromEnum cspace (#poke th_info, pixel_fmt) ptr $ fromEnum pfmt (#poke th_info, target_bitrate) ptr brate (#poke th_info, quality) ptr qual (#poke th_info, keyframe_granule_shift) ptr kframe data OggPacket=Packet {packet::Ptr CChar, bytes::CLong, bos::CLong, eos::CLong, granulePos::Int64, packetNo::Int64} instance Storable OggPacket where sizeOf _= #size ogg_packet alignment _=1 peek ptr=do packet<-(#peek ogg_packet, packet) ptr bytes<-(#peek ogg_packet, bytes) ptr bos<-(#peek ogg_packet, b_o_s) ptr eos<-(#peek ogg_packet, e_o_s) ptr granulePos<-(#peek ogg_packet, granulepos) ptr packetNo<-(#peek ogg_packet, packetno) 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 (#poke ogg_packet, packet) ptr pack (#poke ogg_packet, bytes) ptr bytes (#poke ogg_packet, b_o_s) ptr bos (#poke ogg_packet, e_o_s) ptr eos (#poke ogg_packet, granulepos) ptr gpos (#poke ogg_packet, packetno) ptr pno {- instance Show OggPacket where show (Packet p b bos eos gran no)= unsafePerformIO (peekCStringLen (p,fromIntegral b)) -} 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()) -- | Makes an encoder ('EncCtx') instance out of an 'Info' record 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], -- ^Your comments vendor::String -- ^Name of the encoder, i.e. your application } instance Storable Comment where sizeOf _ = #size th_comment alignment _=1 peek ptr=do length<- (#peek th_comment, comments) ptr c_userComments<-peekArray length =<< (#peek th_comment, comments) ptr userComments<-mapM (peekCString) c_userComments vendor<-(#peek th_comment, vendor) ptr >>= peekCString return $Comment {user=userComments, vendor=vendor} poke ptr comment= do -- user_comments userComments<-mallocArray (length $ user comment) cstrings<-mapM (\str->newCString str) $user comment pokeArray userComments cstrings (#poke th_comment, user_comments) ptr userComments -- comments_length commentLengths<-mallocArray (length $ user comment) pokeArray commentLengths (map length $ user comment) (#poke th_comment, comment_lengths) ptr commentLengths -- length (#poke th_comment, comments) ptr (length $ user comment) -- vendor (#poke th_comment, vendor) 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 -- | Returns the last header packets. This function should be called before -- encoding actual video. 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 _= #size th_img_plane alignment _=1 peek ptr=do width<-(#peek th_img_plane, width) ptr height<-(#peek th_img_plane, height) ptr stride<-(#peek th_img_plane, stride) ptr img<-((#peek th_img_plane, data) ptr) >>= newForeignPtr finalizerFree return $ ImgPlane {width=width, height=height, stride=stride, img=img} poke ptr (ImgPlane w h s i)=do (#poke th_img_plane, width) ptr w (#poke th_img_plane, height) ptr h (#poke th_img_plane, stride) ptr s withForeignPtr i (\img->(#poke th_img_plane, data) ptr img) foreign import ccall "theora/theora.h th_encode_ycbcr_in" th_encode_ycbcr_in:: (Ptr ThEncCtx)->(Ptr YCbCrBuffer)->IO CInt -- | 'YCbCrBuffer' is the type of raw YCbCr frames data YCbCrBuffer=YCbCr { y ::ImgPlane, -- ^ the Y plane cb::ImgPlane, -- ^ the Cb plane cr::ImgPlane -- ^ the Cr plane } instance Storable YCbCrBuffer where sizeOf _= #size th_ycbcr_buffer 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 -- |Allocate a new YCbCrBuffer object 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} -- |Submits a frame for encoding 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 -- |Retrieve all the ready encoded packets 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 _= #size ogg_page alignment _=1 peek ptr=do header<-(#peek ogg_page, header) ptr headerLen<-(#peek ogg_page, header_len) ptr body<-(#peek ogg_page, body) ptr bodyLen<-(#peek ogg_page, body_len) ptr return $ OggPage{header=header, headerLen=headerLen, body=body, bodyLen=bodyLen} poke ptr x=do (#poke ogg_page, header) ptr (header x) (#poke ogg_page, header_len) ptr (headerLen x) (#poke ogg_page, body) ptr $ body x (#poke ogg_page, body_len) 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 _= #size ogg_stream_state 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 -- |Initializes an Ogg container stream newOggStreamState::Int->IO OggStreamState newOggStreamState initial=do state<-malloc success<-ogg_stream_init state $ fromIntegral initial newForeignPtr finalizerFree state -- |Submits an encoded packet into the streams streamPacketIn::OggStreamState->OggPacket->IO () streamPacketIn state packet= withForeignPtr state (\s-> alloca(\pack->do poke pack packet ogg_stream_packetin s pack return ())) -- |Get an outputable Ogg page 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)) -- | Retrieve the last pages of the stream 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) ))