diff --git a/basis/base64/base64.factor b/basis/base64/base64.factor index 747cfa1128..7097de6c6e 100644 --- a/basis/base64/base64.factor +++ b/basis/base64/base64.factor @@ -1,12 +1,13 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math sequences io.binary splitting grouping ; +USING: kernel math sequences io.binary splitting grouping +accessors ; IN: base64 r [ length ] keep r> find-last drop dup [ - 1- ] [ 2drop 0 ] if ; inline +: count-end ( seq quot -- n ) + trim-right-slice [ seq>> length ] [ to>> ] bi - ; inline : ch>base64 ( ch -- ch ) "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" nth ; @@ -21,13 +22,16 @@ IN: base64 } nth ; : encode3 ( seq -- seq ) - be> 4 [ -6 * shift HEX: 3f bitand ch>base64 ] with B{ } map-as ; + be> 4 [ + -6 * shift HEX: 3f bitand ch>base64 + ] with B{ } map-as ; : decode4 ( str -- str ) 0 [ base64>ch swap 6 shift bitor ] reduce 3 >be ; : >base64-rem ( str -- str ) - [ 3 0 pad-right encode3 ] [ length 1+ ] bi head 4 CHAR: = pad-right ; + [ 3 0 pad-right encode3 ] [ length 1+ ] bi + head-slice 4 CHAR: = pad-right ; PRIVATE> @@ -42,5 +46,5 @@ PRIVATE> : base64> ( base64 -- str ) #! input length must be a multiple of 4 [ 4 [ decode4 ] map concat ] - [ [ CHAR: = = not ] count-end ] + [ [ CHAR: = = ] count-end ] bi head* ; diff --git a/basis/db/db-docs.factor b/basis/db/db-docs.factor index 9395fcce32..f8e3956b3e 100644 --- a/basis/db/db-docs.factor +++ b/basis/db/db-docs.factor @@ -12,11 +12,11 @@ HELP: new-db { $description "Creates a new database object from a given class." } ; HELP: make-db* -{ $values { "seq" sequence } { "db" object } { "db" object } } +{ $values { "object" object } { "db" object } { "db" object } } { $description "Takes a sequence of parameters specific to each database and a class name of the database, and constructs a new database object." } ; HELP: make-db -{ $values { "seq" sequence } { "class" class } { "db" db } } +{ $values { "object" object } { "class" class } { "db" db } } { $description "Takes a sequence of parameters specific to each database and a class name of the database, and constructs a new database object." } ; HELP: db-open diff --git a/basis/random/random.factor b/basis/random/random.factor index 0a421288d5..515c464a5a 100755 --- a/basis/random/random.factor +++ b/basis/random/random.factor @@ -36,9 +36,9 @@ M: f random-32* ( obj -- * ) no-random-number-generator ; : random ( seq -- elt ) [ f ] [ [ - length dup log2 7 + 8 /i 1+ random-bytes - [ length 3 shift 2^ ] [ byte-array>bignum ] bi - swap / * >integer + length dup log2 7 + 8 /i 1+ + [ random-bytes byte-array>bignum ] + [ 3 shift 2^ ] bi / * >integer ] keep nth ] if-empty ; diff --git a/extra/webapps/ip/ip.factor b/extra/webapps/ip/ip.factor new file mode 100644 index 0000000000..7124d4a5c4 --- /dev/null +++ b/extra/webapps/ip/ip.factor @@ -0,0 +1,16 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors furnace.actions http.server.dispatchers +html.forms io.servers.connection namespaces prettyprint ; +IN: webapps.ip + +TUPLE: ip-app < dispatcher ; + +: ( -- action ) + + [ remote-address get host>> "ip" set-value ] >>init + { ip-app "ip" } >>template ; + +: ( -- dispatcher ) + ip-app new-dispatcher + "" add-responder ; diff --git a/extra/webapps/ip/ip.xml b/extra/webapps/ip/ip.xml new file mode 100644 index 0000000000..c8529c27ce --- /dev/null +++ b/extra/webapps/ip/ip.xml @@ -0,0 +1,7 @@ + + + + Your IP address is: + + + diff --git a/unmaintained/ogg/player/player.factor b/unmaintained/ogg/player/player.factor index 251206f1d1..2204aa441e 100755 --- a/unmaintained/ogg/player/player.factor +++ b/unmaintained/ogg/player/player.factor @@ -15,7 +15,7 @@ USING: kernel alien ogg ogg.vorbis ogg.theora io byte-arrays namespaces threads shuffle opengl arrays ui.gadgets.worlds combinators math.parser ui.gadgets ui.render opengl.gl ui continuations io.files hints combinators.lib sequences.lib - io.encodings.binary debugger math.order ; + io.encodings.binary debugger math.order accessors ; IN: ogg.player @@ -30,62 +30,63 @@ TUPLE: player stream temp-state gadget ; : init-vorbis ( player -- ) - dup player-oy ogg_sync_init drop - dup player-vi vorbis_info_init - player-vc vorbis_comment_init ; + dup oy>> ogg_sync_init drop + dup vi>> vorbis_info_init + vc>> vorbis_comment_init ; : init-theora ( player -- ) - dup player-ti theora_info_init - player-tc theora_comment_init ; + dup ti>> theora_info_init + tc>> theora_comment_init ; : init-sound ( player -- ) init-openal check-error - 1 gen-buffers check-error over set-player-buffers - 2 "uint" over set-player-buffer-indexes - 1 gen-sources check-error first swap set-player-source ; + 1 gen-buffers check-error >>buffers + 2 "uint" >>buffer-indexes + 1 gen-sources check-error first >>source drop ; : ( stream -- player ) - { set-player-stream } player construct - 0 over set-player-vorbis - 0 over set-player-theora - 0 over set-player-video-time - 0 over set-player-video-granulepos - f over set-player-video-ready? - f over set-player-audio-full? - 0 over set-player-audio-index - 0 over set-player-start-time - audio-buffer-size "short" over set-player-audio-buffer - 0 over set-player-audio-granulepos - f over set-player-playing? - "ogg_packet" malloc-object over set-player-op - "ogg_sync_state" malloc-object over set-player-oy - "ogg_page" malloc-object over set-player-og - "ogg_stream_state" malloc-object over set-player-vo - "vorbis_info" malloc-object over set-player-vi - "vorbis_dsp_state" malloc-object over set-player-vd - "vorbis_block" malloc-object over set-player-vb - "vorbis_comment" malloc-object over set-player-vc - "ogg_stream_state" malloc-object over set-player-to - "theora_info" malloc-object over set-player-ti - "theora_comment" malloc-object over set-player-tc - "theora_state" malloc-object over set-player-td - "yuv_buffer" over set-player-yuv - "ogg_stream_state" over set-player-temp-state - dup init-sound - dup init-vorbis - dup init-theora ; + player new + swap >>stream + 0 >>vorbis + 0 >>theora + 0 >>video-time + 0 >>video-granulepos + f >>video-ready? + f >>audio-full? + 0 >>audio-index + 0 >>start-time + audio-buffer-size "short" >>audio-buffer + 0 >>audio-granulepos + f >>playing? + "ogg_packet" malloc-object >>op + "ogg_sync_state" malloc-object >>oy + "ogg_page" malloc-object >>og + "ogg_stream_state" malloc-object >>vo + "vorbis_info" malloc-object >>vi + "vorbis_dsp_state" malloc-object >>vd + "vorbis_block" malloc-object >>vb + "vorbis_comment" malloc-object >>vc + "ogg_stream_state" malloc-object >>to + "theora_info" malloc-object >>ti + "theora_comment" malloc-object >>tc + "theora_state" malloc-object >>td + "yuv_buffer" >>yuv + "ogg_stream_state" >>temp-state + dup init-sound + dup init-vorbis + dup init-theora ; : num-channels ( player -- channels ) - player-vi vorbis_info-channels ; + vi>> vorbis_info-channels ; : al-channel-format ( player -- format ) - num-channels 1 = [ AL_FORMAT_MONO16 ] [ AL_FORMAT_STEREO16 ] if ; + num-channels 1 = AL_FORMAT_MONO16 AL_FORMAT_STEREO16 ? ; : get-time ( player -- time ) - dup player-start-time zero? [ - millis over set-player-start-time + dup start-time>> zero? [ + millis >>start-time ] when - player-start-time millis swap - 1000.0 /f ; + start-time>> millis swap - 1000.0 /f ; : clamp ( n -- n ) 255 min 0 max ; inline @@ -138,7 +139,7 @@ TUPLE: player stream temp-state pick yuv_buffer-y_width >fixnum [ yuv>rgb-pixel ] each-with4 ; inline -: yuv>rgb ( rgb yuv -- ) +: yuv>rgb ( rgb yuv -- ) 0 -rot dup yuv_buffer-y_height >fixnum [ yuv>rgb-row ] each-with2 @@ -147,52 +148,55 @@ TUPLE: player stream temp-state HINTS: yuv>rgb byte-array byte-array ; : process-video ( player -- player ) - dup player-gadget [ - dup { player-td player-yuv } get-slots theora_decode_YUVout drop - dup player-rgb over player-yuv yuv>rgb - dup player-gadget relayout-1 yield + dup gadget>> [ + { + [ [ td>> ] [ yuv>> ] bi theora_decode_YUVout drop ] + [ [ rgb>> ] [ yuv>> ] bi yuv>rgb ] + [ gadget>> relayout-1 yield ] + [ ] + } cleave ] when ; : num-audio-buffers-processed ( player -- player n ) - dup player-source AL_BUFFERS_PROCESSED 0 + dup source>> AL_BUFFERS_PROCESSED 0 [ alGetSourcei check-error ] keep *uint ; : append-new-audio-buffer ( player -- player ) - dup player-buffers 1 gen-buffers append over set-player-buffers - [ [ player-buffers second ] keep al-channel-format ] keep - [ player-audio-buffer dup length ] keep - [ player-vi vorbis_info-rate alBufferData check-error ] keep - [ player-source 1 ] keep - [ player-buffers second alSourceQueueBuffers check-error ] keep ; + dup buffers>> 1 gen-buffers append >>buffers + [ [ buffers>> second ] keep al-channel-format ] keep + [ audio-buffer>> dup length ] keep + [ vi>> vorbis_info-rate alBufferData check-error ] keep + [ source>> 1 ] keep + [ buffers>> second alSourceQueueBuffers check-error ] keep ; : fill-processed-audio-buffer ( player n -- player ) #! n is the number of audio buffers processed - over >r >r dup player-source r> pick player-buffer-indexes + over >r >r dup source>> r> pick buffer-indexes>> [ alSourceUnqueueBuffers check-error ] keep *uint dup r> swap >r al-channel-format rot - [ player-audio-buffer dup length ] keep - [ player-vi vorbis_info-rate alBufferData check-error ] keep - [ player-source 1 ] keep + [ audio-buffer>> dup length ] keep + [ vi>> vorbis_info-rate alBufferData check-error ] keep + [ source>> 1 ] keep r> swap >r alSourceQueueBuffers check-error r> ; : append-audio ( player -- player bool ) num-audio-buffers-processed { - { [ over player-buffers length 1 = over zero? and ] [ drop append-new-audio-buffer t ] } - { [ over player-buffers length 2 = over zero? and ] [ yield drop f ] } + { [ over buffers>> length 1 = over zero? and ] [ drop append-new-audio-buffer t ] } + { [ over buffers>> length 2 = over zero? and ] [ yield drop f ] } [ fill-processed-audio-buffer t ] } cond ; : start-audio ( player -- player bool ) - [ [ player-buffers first ] keep al-channel-format ] keep - [ player-audio-buffer dup length ] keep - [ player-vi vorbis_info-rate alBufferData check-error ] keep - [ player-source 1 ] keep - [ player-buffers first alSourceQueueBuffers check-error ] keep - [ player-source alSourcePlay check-error ] keep - t over set-player-playing? t ; + [ [ buffers>> first ] keep al-channel-format ] keep + [ audio-buffer>> dup length ] keep + [ vi>> vorbis_info-rate alBufferData check-error ] keep + [ source>> 1 ] keep + [ buffers>> first alSourceQueueBuffers check-error ] keep + [ source>> alSourcePlay check-error ] keep + t >>playing? t ; : process-audio ( player -- player bool ) - dup player-playing? [ append-audio ] [ start-audio ] if ; + dup playing?>> [ append-audio ] [ start-audio ] if ; : read-bytes-into ( dest size stream -- len ) #! Read the given number of bytes from a stream @@ -206,13 +210,13 @@ HINTS: yuv>rgb byte-array byte-array ; 4096 ; inline : sync-buffer ( player -- buffer size player ) - [ player-oy buffer-size ogg_sync_buffer buffer-size ] keep ; + [ oy>> buffer-size ogg_sync_buffer buffer-size ] keep ; : stream-into-buffer ( buffer size player -- len player ) - [ player-stream read-bytes-into ] keep ; + [ stream>> read-bytes-into ] keep ; : confirm-buffer ( len player -- player eof? ) - [ player-oy swap ogg_sync_wrote check-not-negative ] 2keep swap zero? ; + [ oy>> swap ogg_sync_wrote check-not-negative ] 2keep swap zero? ; : buffer-data ( player -- player eof? ) #! Take some compressed bitstream data and sync it for @@ -221,59 +225,60 @@ HINTS: yuv>rgb byte-array byte-array ; : queue-page ( player -- player ) #! Push a page into the stream for packetization - [ { player-vo player-og } get-slots ogg_stream_pagein drop ] keep - [ { player-to player-og } get-slots ogg_stream_pagein drop ] keep ; + [ [ vo>> ] [ og>> ] bi ogg_stream_pagein drop ] + [ [ to>> ] [ og>> ] bi ogg_stream_pagein drop ] + [ ] tri ; : retrieve-page ( player -- player bool ) #! Sync the streams and get a page. Return true if a page was #! successfully retrieved. - dup { player-oy player-og } get-slots ogg_sync_pageout 0 > ; + dup [ oy>> ] [ og>> ] bi ogg_sync_pageout 0 > ; : standard-initial-header? ( player -- player bool ) - dup player-og ogg_page_bos zero? not ; + dup og>> ogg_page_bos zero? not ; : ogg-stream-init ( player -- state player ) #! Init the encode/decode logical stream state - [ player-temp-state ] keep - [ player-og ogg_page_serialno ogg_stream_init check-not-negative ] 2keep ; + [ temp-state>> ] keep + [ og>> ogg_page_serialno ogg_stream_init check-not-negative ] 2keep ; : ogg-stream-pagein ( state player -- state player ) #! Add the incoming page to the stream state - [ player-og ogg_stream_pagein drop ] 2keep ; + [ og>> ogg_stream_pagein drop ] 2keep ; : ogg-stream-packetout ( state player -- state player ) - [ player-op ogg_stream_packetout drop ] 2keep ; + [ op>> ogg_stream_packetout drop ] 2keep ; : decode-packet ( player -- state player ) ogg-stream-init ogg-stream-pagein ogg-stream-packetout ; : theora-header? ( player -- player bool ) #! Is the current page a theora header? - dup { player-ti player-tc player-op } get-slots theora_decode_header 0 >= ; + dup [ ti>> ] [ tc>> ] [ op>> ] tri theora_decode_header 0 >= ; : is-theora-packet? ( player -- player bool ) - dup player-theora zero? [ theora-header? ] [ f ] if ; + dup theora>> zero? [ theora-header? ] [ f ] if ; : copy-to-theora-state ( state player -- player ) #! Copy the state to the theora state structure in the player - [ player-to swap dup length memcpy ] keep ; + [ to>> swap dup length memcpy ] keep ; : handle-initial-theora-header ( state player -- player ) - copy-to-theora-state 1 over set-player-theora ; + copy-to-theora-state 1 >>theora ; : vorbis-header? ( player -- player bool ) #! Is the current page a vorbis header? - dup { player-vi player-vc player-op } get-slots vorbis_synthesis_headerin 0 >= ; + dup [ vi>> ] [ vc>> ] [ op>> ] tri vorbis_synthesis_headerin 0 >= ; : is-vorbis-packet? ( player -- player bool ) - dup player-vorbis zero? [ vorbis-header? ] [ f ] if ; + dup vorbis>> zero? [ vorbis-header? ] [ f ] if ; : copy-to-vorbis-state ( state player -- player ) #! Copy the state to the vorbis state structure in the player - [ player-vo swap dup length memcpy ] keep ; + [ vo>> swap dup length memcpy ] keep ; : handle-initial-vorbis-header ( state player -- player ) - copy-to-vorbis-state 1 over set-player-vorbis ; + copy-to-vorbis-state 1 >>vorbis ; : handle-initial-unknown-header ( state player -- player ) swap ogg_stream_clear drop ; @@ -308,43 +313,43 @@ HINTS: yuv>rgb byte-array byte-array ; #! Return true if we need to decode vorbis due to there being #! vorbis headers read from the stream but we don't have them all #! yet. - dup player-vorbis 1 2 between? not ; + dup vorbis>> 1 2 between? not ; : have-required-theora-headers? ( player -- player bool ) #! Return true if we need to decode theora due to there being #! theora headers read from the stream but we don't have them all #! yet. - dup player-theora 1 2 between? not ; + dup theora>> 1 2 between? not ; : get-remaining-vorbis-header-packet ( player -- player bool ) - dup { player-vo player-op } get-slots ogg_stream_packetout { + dup [ vo>> ] [ op>> ] bi ogg_stream_packetout { { [ dup 0 < ] [ "Error parsing vorbis stream; corrupt stream?" throw ] } { [ dup zero? ] [ drop f ] } { [ t ] [ drop t ] } } cond ; : get-remaining-theora-header-packet ( player -- player bool ) - dup { player-to player-op } get-slots ogg_stream_packetout { + dup [ to>> ] [ op>> ] bi ogg_stream_packetout { { [ dup 0 < ] [ "Error parsing theora stream; corrupt stream?" throw ] } { [ dup zero? ] [ drop f ] } { [ t ] [ drop t ] } } cond ; : decode-remaining-vorbis-header-packet ( player -- player ) - dup { player-vi player-vc player-op } get-slots vorbis_synthesis_headerin zero? [ + dup [ vi>> ] [ vc>> ] [ op>> ] tri vorbis_synthesis_headerin zero? [ "Error parsing vorbis stream; corrupt stream?" throw ] unless ; : decode-remaining-theora-header-packet ( player -- player ) - dup { player-ti player-tc player-op } get-slots theora_decode_header zero? [ + dup [ ti>> ] [ tc>> ] [ op>> ] tri theora_decode_header zero? [ "Error parsing theora stream; corrupt stream?" throw ] unless ; : increment-vorbis-header-count ( player -- player ) - dup player-vorbis 1+ over set-player-vorbis ; + [ 1+ ] change-vorbis ; : increment-theora-header-count ( player -- player ) - dup player-theora 1+ over set-player-theora ; + [ 1+ ] change-theora ; : parse-remaining-vorbis-headers ( player -- player ) have-required-vorbis-headers? not [ @@ -376,51 +381,51 @@ HINTS: yuv>rgb byte-array byte-array ; ] when ; : tear-down-vorbis ( player -- player ) - dup player-vi vorbis_info_clear - dup player-vc vorbis_comment_clear ; + dup vi>> vorbis_info_clear + dup vc>> vorbis_comment_clear ; : tear-down-theora ( player -- player ) - dup player-ti theora_info_clear - dup player-tc theora_comment_clear ; + dup ti>> theora_info_clear + dup tc>> theora_comment_clear ; : init-vorbis-codec ( player -- player ) - dup { player-vd player-vi } get-slots vorbis_synthesis_init drop - dup { player-vd player-vb } get-slots vorbis_block_init drop ; + dup [ vd>> ] [ vi>> ] bi vorbis_synthesis_init drop + dup [ vd>> ] [ vb>> ] bi vorbis_block_init drop ; : init-theora-codec ( player -- player ) - dup { player-td player-ti } get-slots theora_decode_init drop - dup player-ti theora_info-frame_width over player-ti theora_info-frame_height - 4 * * over set-player-rgb ; + dup [ td>> ] [ ti>> ] bi theora_decode_init drop + dup ti>> theora_info-frame_width over ti>> theora_info-frame_height + 4 * * >>rgb ; : display-vorbis-details ( player -- player ) [ "Ogg logical stream " % - dup player-vo ogg_stream_state-serialno # + dup vo>> ogg_stream_state-serialno # " is Vorbis " % - dup player-vi vorbis_info-channels # + dup vi>> vorbis_info-channels # " channel " % - dup player-vi vorbis_info-rate # + dup vi>> vorbis_info-rate # " Hz audio." % ] "" make print ; : display-theora-details ( player -- player ) [ "Ogg logical stream " % - dup player-to ogg_stream_state-serialno # + dup to>> ogg_stream_state-serialno # " is Theora " % - dup player-ti theora_info-width # + dup ti>> theora_info-width # "x" % - dup player-ti theora_info-height # + dup ti>> theora_info-height # " " % - dup player-ti theora_info-fps_numerator - over player-ti theora_info-fps_denominator /f # + dup ti>> theora_info-fps_numerator + over ti>> theora_info-fps_denominator /f # " fps video" % ] "" make print ; : initialize-decoder ( player -- player ) - dup player-vorbis zero? [ tear-down-vorbis ] [ init-vorbis-codec display-vorbis-details ] if - dup player-theora zero? [ tear-down-theora ] [ init-theora-codec display-theora-details ] if ; + dup vorbis>> zero? [ tear-down-vorbis ] [ init-vorbis-codec display-vorbis-details ] if + dup theora>> zero? [ tear-down-theora ] [ init-theora-codec display-theora-details ] if ; : sync-pages ( player -- player ) retrieve-page [ @@ -428,13 +433,13 @@ HINTS: yuv>rgb byte-array byte-array ; ] when ; : audio-buffer-not-ready? ( player -- player bool ) - dup player-vorbis zero? not over player-audio-full? not and ; + dup vorbis>> zero? not over audio-full?>> not and ; : pending-decoded-audio? ( player -- player pcm len bool ) - f 2dup >r player-vd r> vorbis_synthesis_pcmout dup 0 > ; + f 2dup >r vd>> r> vorbis_synthesis_pcmout dup 0 > ; : buffer-space-available ( player -- available ) - audio-buffer-size swap player-audio-index - ; + audio-buffer-size swap audio-index>> - ; : samples-to-read ( player available len -- numread ) >r swap num-channels / r> min ; @@ -442,8 +447,8 @@ HINTS: yuv>rgb byte-array byte-array ; : each-with3 ( obj obj obj seq quot -- ) 3 each-withn ; inline : add-to-buffer ( player val -- ) - over player-audio-index pick player-audio-buffer set-short-nth - dup player-audio-index 1+ swap set-player-audio-index ; + over audio-index>> pick audio-buffer>> set-short-nth + [ 1+ ] change-audio-index drop ; : get-audio-value ( pcm sample channel -- value ) rot *void* void*-nth float-nth ; @@ -462,24 +467,24 @@ HINTS: yuv>rgb byte-array byte-array ; pick [ buffer-space-available swap ] keep -rot samples-to-read pick over >r >r process-samples r> r> swap ! numread player - dup player-audio-index audio-buffer-size = [ - t over set-player-audio-full? + dup audio-index>> audio-buffer-size = [ + t >>audio-full? ] when - dup player-vd vorbis_dsp_state-granulepos dup 0 >= [ + dup vd>> vorbis_dsp_state-granulepos dup 0 >= [ ! numtoread player granulepos #! This is wrong: fix - pick - over set-player-audio-granulepos + pick - >>audio-granulepos ] [ ! numtoread player granulepos - pick + over set-player-audio-granulepos + pick + >>audio-granulepos ] if - [ player-vd swap vorbis_synthesis_read drop ] keep ; + [ vd>> swap vorbis_synthesis_read drop ] keep ; : no-pending-audio ( player -- player bool ) #! No pending audio. Is there a pending packet to decode. - dup { player-vo player-op } get-slots ogg_stream_packetout 0 > [ - dup { player-vb player-op } get-slots vorbis_synthesis 0 = [ - dup { player-vd player-vb } get-slots vorbis_synthesis_blockin drop + dup [ vo>> ] [ op>> ] bi ogg_stream_packetout 0 > [ + dup [ vb>> ] [ op>> ] bi vorbis_synthesis 0 = [ + dup [ vd>> ] [ vb>> ] bi vorbis_synthesis_blockin drop ] when t ] [ @@ -498,16 +503,16 @@ HINTS: yuv>rgb byte-array byte-array ; ] when ; : video-buffer-not-ready? ( player -- player bool ) - dup player-theora zero? not over player-video-ready? not and ; + dup theora>> zero? not over video-ready?>> not and ; : decode-video ( player -- player ) video-buffer-not-ready? [ - dup { player-to player-op } get-slots ogg_stream_packetout 0 > [ - dup { player-td player-op } get-slots theora_decode_packetin drop - dup player-td theora_state-granulepos over set-player-video-granulepos - dup { player-td player-video-granulepos } get-slots theora_granule_time - over set-player-video-time - t over set-player-video-ready? + dup [ to>> ] [ op>> ] bi ogg_stream_packetout 0 > [ + dup [ td>> ] [ op>> ] bi theora_decode_packetin drop + dup td>> theora_state-granulepos >>video-granulepos + dup [ td>> ] [ video-granulepos>> ] bi theora_granule_time + >>video-time + t >>video-ready? decode-video ] when ] when ; @@ -516,16 +521,16 @@ HINTS: yuv>rgb byte-array byte-array ; get-more-header-data sync-pages decode-audio decode-video - dup player-audio-full? [ + dup audio-full?>> [ process-audio [ - f over set-player-audio-full? - 0 over set-player-audio-index + f >>audio-full? + 0 >>audio-index ] when ] when - dup player-video-ready? [ - dup player-video-time over get-time - dup 0.0 < [ + dup video-ready?>> [ + dup video-time>> over get-time - dup 0.0 < [ -0.1 > [ process-video ] when - f over set-player-video-ready? + f >>video-ready? ] [ drop ] if @@ -533,36 +538,39 @@ HINTS: yuv>rgb byte-array byte-array ; decode ; : free-malloced-objects ( player -- player ) - [ player-op free ] keep - [ player-oy free ] keep - [ player-og free ] keep - [ player-vo free ] keep - [ player-vi free ] keep - [ player-vd free ] keep - [ player-vb free ] keep - [ player-vc free ] keep - [ player-to free ] keep - [ player-ti free ] keep - [ player-tc free ] keep - [ player-td free ] keep ; + { + [ op>> free ] + [ oy>> free ] + [ og>> free ] + [ vo>> free ] + [ vi>> free ] + [ vd>> free ] + [ vb>> free ] + [ vc>> free ] + [ to>> free ] + [ ti>> free ] + [ tc>> free ] + [ td>> free ] + [ ] + } cleave ; : unqueue-openal-buffers ( player -- player ) [ - num-audio-buffers-processed over player-source rot player-buffer-indexes swapd + num-audio-buffers-processed over source>> rot buffer-indexes>> swapd alSourceUnqueueBuffers check-error ] keep ; : delete-openal-buffers ( player -- player ) [ - player-buffers [ + buffers>> [ 1 swap alDeleteBuffers check-error ] each ] keep ; : delete-openal-source ( player -- player ) - [ player-source 1 swap alDeleteSources check-error ] keep ; + [ source>> 1 swap alDeleteSources check-error ] keep ; : cleanup ( player -- player ) free-malloced-objects @@ -572,28 +580,28 @@ HINTS: yuv>rgb byte-array byte-array ; : wait-for-sound ( player -- player ) #! Waits for the openal to finish playing remaining sounds - dup player-source AL_SOURCE_STATE 0 [ alGetSourcei check-error ] keep + dup source>> AL_SOURCE_STATE 0 [ alGetSourcei check-error ] keep *int AL_PLAYING = [ 100 sleep wait-for-sound ] when ; -TUPLE: theora-gadget player ; +TUPLE: theora-gadget < gadget player ; : ( player -- gadget ) - theora-gadget construct-gadget - [ set-theora-gadget-player ] keep ; + theora-gadget new-gadget + swap >>player ; M: theora-gadget pref-dim* - theora-gadget-player - player-ti dup theora_info-width swap theora_info-height 2array ; + player>> + ti>> dup theora_info-width swap theora_info-height 2array ; M: theora-gadget draw-gadget* ( gadget -- ) 0 0 glRasterPos2i 1.0 -1.0 glPixelZoom GL_UNPACK_ALIGNMENT 1 glPixelStorei [ pref-dim* first2 GL_RGB GL_UNSIGNED_BYTE ] keep - theora-gadget-player player-rgb glDrawPixels ; + player>> rgb>> glDrawPixels ; : initialize-gui ( gadget -- ) "Theora Player" open-window ; @@ -602,7 +610,7 @@ M: theora-gadget draw-gadget* ( gadget -- ) parse-initial-headers parse-remaining-headers initialize-decoder - dup player-gadget [ initialize-gui ] when* + dup gadget>> [ initialize-gui ] when* [ decode ] try wait-for-sound cleanup @@ -616,9 +624,8 @@ M: theora-gadget draw-gadget* ( gadget -- ) : play-theora-stream ( stream -- ) - dup over set-player-gadget + dup >>gadget play-ogg ; : play-theora-file ( filename -- ) binary play-theora-stream ; -