Rebol [ title: "SWF creator" Author: "oldes" File: %make-swf.r Email: oliva.david@seznam.cz ] ins: func[b [binary!]][insert tail body b] ins-act: func[b [binary!]][ if all [b/1 <> 150 not empty? action-push-buff][ form-push/compact/nobuff action-push-buff clear action-push-buff ] insert tail action-bin b ] quiet?: off swf-version: 4 utf8-encode?: true ;if I have strings already encoded, I need to turn off this switch!!! frames: 0 init: does [ swf-framerate: 12 ;default frame rate including: false ;to disable 'end and 'background tags in the included scripts included-files: make block! 5 ;this is used by 'require dialect word to store informations about files which are already included, so this file is not included only once body: make binary! 10000 ConstantPool: make block! 20 animations: make block! 10 ;array which hold information of animations - processed before showframe action action-bin: make binary! 1000 action-bin-buff: make block! 1000 action-push-buff: make block! 10 sprite-recursion-buff: make block! 10 max-bits: 0 ;I use this variable while converting integers to signed bytes set-word-buff: make block! 30 ;This variable will be set by any set-word! in the dialect current-set-word: none set-word: func[][ ;print ["Set-word:" mold set-word-buff] return current-set-word: either empty? set-word-buff [none][first set-word-buff] ] last-id: none ;This should hold the last used ID last-depth: 0 used-ids: make block! 50 ;To be able find new ID that is not used yet, I need this var. stream: none ;used for sound streaming (object! if used) names-ids-table: make block! 100 ;This block will hold informations, which which unique name is equal to which character ID. ; For example: [my_ball 10 shp_tree 12] ; will be set by: my_ball: Shape [id 10 ...] and so on ; so I will be able to use: PlaceObject my_ball [at 10x10] ; instead of: PlaceObject 10 [at 0x0] placed-images: make block! 100 ;to have informations about image sizes placed-objects: make block! 100 ;to be able create simple animations from the dialect ;I must know some informations about already placed objects in the scene that has own names ;This table will looks like: ;[depth [offset]] - depth is the key ID for placed object, because it's not posible to animate more objects with the same depth ;defined-objects: make block! 100 ;same as 'declared-funcs but for objects and their methods ;defined-methods: make block! 100 WindowClassCreated?: false local-constants: [ ;key codes: Backspace 8 Tab 9 Clear 12 Enter 13 Shift 16 Control 17 Alt 18 CapsLock 20 Esc 27 Spacebar 32 PageUp 33 PageDown 34 End 35 Home 36 Left 37 Up 38 Right 39 Down 40 Insert 45 Delete 46 Help 47 NumLock 144 F1 112 F2 113 F3 114 F4 115 F5 116 F6 117 F7 118 F8 119 F9 120 F10 121 F11 122 F12 123 ] ] swf5properties: [ _x 0 ;#{060000000000000000} _y 1 ;#{0007010000} _xscale 2 ;#{0007020000} _yscale 3 ;#{0007030000} _totalframes 5 ;#{0007050000} _alpha 6 ;#{0007060000} _visible 7 ;#{0007070000} _width 8 ;#{0007080000} _height 9 ;#{0007090000} _rotation 10 ;#{00070A0000} _framesloaded 12 ;#{00070C0000} _name 13 ;#{00070D0000} _highquality 16 ;#{0007100000} _soundbuftime 18 ;#{0007120000} _quality 19 ;#{0007130000} ] init decimal: make object! load %decimal.rinc ;do %round.r do %actions.rinc ;Actions-parser object do %sound-fce.rinc do %classes-compiler.rinc tag-rules: load %swf-tag-rules.rb issue-to-binary: func[clr ][load head insert tail insert next mold clr "{" "}"] load-img: func[file id /alpha /size sz /key kcolor /local tmp bin x y type ext bll-file][ ;print [file id] file: copy file ext: last parse file "." bin: make binary! 10000 file: get-filepath file either find ["jpg" "jpeg"] ext [ ;Jpegs either exists? file [ insert bin read/binary file ][ print ["Cannot find the image file" file "!!"] ] if not empty? bin [ ;print "Warning: JPGs must be in saved as Baseline (standart) - no progressive JPGS" either size [size: sz][ tmp: load file size: tmp/size clear tmp] ins form-tag 21 join set-id id jpg-analyse/quiet bin insert placed-images reduce [last-id size] ] ][ ;bitsLossless type: either any [alpha key] [36][20] bll-file: rejoin [file "." type] if any [ all [ not exists? tmp: bll-file not exists? tmp: rswf-root-dir/:bll-file not exists? tmp: rswf-project-dir/:bll-file ] all [ exists? file (modified? file) > (modified? tmp) ] ][ switch type [ 36 [write/binary bll-file img-to-bll/key file either key [kcolor][123.109.57]] 20 [write/binary bll-file img-to-bll file] ] ] either error? try [bin: read/binary bll-file][ print ["Cannot find the image file" bll-file "!!"] ][ parse/all bin [1 skip copy x 2 skip copy y 2 skip to end] size: to pair! reduce [bin-to-int to binary! x bin-to-int to binary! y] ins form-tag type join set-id id bin insert placed-images reduce [last-id size] ] ] ] create-img: func[img [image!] id /param par /local type kcolor][ type: 20 if all [param block? par] [ parse par [some ['key set kcolor tuple! (type: 36) | any-type!]] ] ins form-tag type join either none? id [set-id id][set-id/as id] either type = 20 [img-to-bll img][img-to-bll/key img kcolor] insert placed-images reduce [last-id img/size] ] get-id: func[ "Will try to find the ID and sets the last-id" char [word! integer!] "The characters name" /local id ][ id: either integer? char [char][select names-ids-table char] if none? id [id: 1] last-id: id ] get-new-id: func[][ either empty? used-ids [1][ 1 + last sort used-ids ] ] pop-set-word: func[/local sw][ sw: first set-word-buff remove set-word-buff sw ] do-set-word: func[i /as word /local f w][ w: either as [word][set-word] if not none? w [ either found? f: find/tail names-ids-table w [ change f i ][ insert names-ids-table i insert names-ids-table w ] if not as [remove set-word-buff] ] ] set-id: func[id /as][ if not integer? id [ if as [id-word: id] id: get-new-id ] if not found? find used-ids id [insert used-ids id] either as [ do-set-word/as id id-word ][ do-set-word id] last-id: id int-to-ui16 id ] make-object: func[name args /define /local tmp a m i val][ actions-parser/pop?: false a: make binary! 2 if not none? set-word [ either binary? set-word [ insert tail action-bin pop-set-word insert a either actions-parser/localVar? [#{3C}][#{1D}] ][ tmp: actions-parser/process-set-path copy [] pop-set-word insert a copy last tmp remove/part tail tmp -2 do tmp ] ] i: 0 either define [ insert a #{43} ;ActionDefineObject parse args [ any [ copy tmp set-word! (form-push to word! first tmp) copy val [to set-word! | to end] ( i: i + 1 actions-parser/pop?: false compile-actions/no-push-end val actions-parser/pop?: true ) ] ] form-push i ][ parse args [ any [ copy val [paren! | word! | block!] ( compile-actions/no-push-end val actions-parser/removepop) ;| copy val word! (probe val) | copy val any-type! ( form-push first val) ] ] form-push length? args name: to string! name either none? find name "." [ insert a #{40} ;ActionNewObject form-push name ][ name: parse name "." form-push first name ins-act #{1C} ;getVar foreach n next name [ form-push n ins-act #{4E} ;getMember ] remove back tail action-bin insert a #{53} ;NewMethod ] ] ins-act a actions-parser/pop?: true ] make-warning!: func[val /msg m][ prin "WARNING: " print either msg [m][ rejoin [ "misplaced item: " mold first val newline " NEAR: " copy/part val 4 " ..." ] ] ] get-filepath: func[ "Returns filename with path." file /local f ][ return either any [ exists? f: file (probe f false) exists? f: rswf-root-dir/:file (probe f false) exists? f: rswf-project-dir/:file (probe f false) exists? f: rswf-root-dir/bitmaps/:file (probe f false) ][ f ][ file ] ] utf8-encode: func[ "Encodes the string data to UTF-8" str [any-string!] "string to encode" /local c ][ str: to binary! str forall str [ if 127 < c: first str [ ;this is made for czech alphabet - I don't like it but I don't ;know better way in this moment:( switch/default c [ 138 [change str #{A0} str: insert str #{c5}] ;Š 141 [change str #{A4} str: insert str #{c5}] ; 142 [change str #{BD} str: insert str #{c5}] ;Ž 154 [change str #{A1} str: insert str #{c5}] ;š 157 [change str #{A5} str: insert str #{c5}] ; 200 [change str #{8C} str: insert str #{c4}] ;È 204 [change str #{9A} str: insert str #{c4}] ;Ì 207 [change str #{8E} str: insert str #{c4}] ;Ï 216 [change str #{98} str: insert str #{c5}] ;Ø 217 [change str #{AE} str: insert str #{c5}] ;Ù 236 [change str #{9B} str: insert str #{c4}] ;ì 239 [change str #{8F} str: insert str #{c4}] ;ï 232 [change str #{8D} str: insert str #{c4}] ;è 248 [change str #{99} str: insert str #{c5}] ;ø 158 [change str #{BE} str: insert str #{c5}] ;ž 249 [change str #{AF} str: insert str #{c5}] ;ù 242 [change str #{88} str: insert str #{c5}] ;ò ][ change str to char! (c and 63 or 128) c: enbase/base to binary! to char! c 2 remove/part tail c -6 c: head insert/dup head c #"0" 6 str: insert str (#{c0} or debase/base c 2) ] ] ] head str ] ;----------------------------------------- bin-to-int: func[bin][to integer! head reverse bin] extend-int: func[num /local i][ i: num // 8 if i > 0 [num: num + 8 - i] num ] byte-align: func[bits [string!] /local p][ p: (length? bits) // 8 if p > 0 [insert/dup tail bits #"0" 8 - p] bits ] bits-to-bin: func[bits [string!]][ load rejoin ["2#{" byte-align bits "}"] ] if error? try [ ui32-struct: make struct! [value [integer!]] none ui16-struct: make struct! [value [short]] none int-to-ui32: func[i][ui32-struct/value: to integer! i copy third ui32-struct] int-to-ui16: func[i][ui16-struct/value: to integer! i copy third ui16-struct] int-to-ui8: func[i][ui16-struct/value: to integer! i copy/part third ui16-struct 1] int-to-bits: func[i [number!] bits][skip enbase/base head reverse int-to-ui32 i 2 32 - bits] ][ ;for Rebol versions where the struct! datatype is not available int-to-ui32: func[i [number!]][head reverse load rejoin ["#{" to-hex to-integer i "}"]] int-to-ui16: func[i [number!]][head reverse load rejoin ["#{" skip mold to-hex to integer! i 5 "}"]] int-to-ui8: func[i [number!]][load rejoin ["#{" skip mold to-hex to integer! i 7 "}"]] int-to-bits: func[i [number!] bits][skip enbase/base load rejoin ["#{" to-hex to integer! i "}"] 2 32 - bits] ] int-to-si16: func[i [number!] /local n][ n: i < 0 if i > 32767 [i: i - (32767 // i)] i: head reverse int-to-ui16 abs i if n [i: i or #{8000}] head reverse i ] ;int-to-sb16: func[int [integer!]][head reverse copy skip load rejoin ["#{" to-hex int "}"] 2] int-to-sb16: :int-to-ui16 bits-needed: func[ "Counts the less number of bits needed to hold the integer" i [integer!] /local b ][ ;b: find enbase/base load rejoin ["#{" to-hex abs i "}"] 2 "1" b: find enbase/base head reverse int-to-ui32 abs i 2 "1" either none? b [0][length? b] ] ints-to-sbs: func[ ints [block!] "Block of integers, that I want to convert to SBs" /complete l-bits "Completes the bit-stream => l-bits stores the nBits info of the values" ;/maxb mb /local b b2 l bits sb ][ ints: reduce ints max-bits: 0 bits: make block! length? ints foreach i ints [ ;b: enbase/base load rejoin ["#{" to-hex i "}"] 2 b: enbase/base head reverse int-to-ui32 i 2 b: find b either i < 0 [#"0"][#"1"] b: copy either none? b [either i >= 0 ["0"]["1"]][back b] ;insert b either i >= 0 [#"0"][#"1"] if max-bits < l: length? b [max-bits: l] append bits b ] foreach b bits [ if max-bits > l: length? b [ insert/dup b b/1 max-bits - l ] ] either complete [ sb: int-to-bits max-bits l-bits foreach b bits [insert tail sb b] sb ][ bits ] ] int-to-FB: func[i /local x y fb][ x: to integer! i y: to integer! (either x = 0 [i][i // x]) * 65535 fb: rejoin [first ints-to-sbs to block! x int-to-bits y 16] if all [x = 0 i < 0][fb/1: #"1"] fb ] form-act-tag: func[id [binary!] data [binary! string!] /get /noend /local t][ if string? data [data: rejoin [#{} data either noend [#{}][#{00}]]] t: rejoin [id int-to-ui16 length? data data] either get [return t][ins-act t] t ] push-str-value: func[v][ ;probe v rejoin either none? f: find ConstantPool v [ either swf-version > 5 [ [#{00} either utf8-encode? [utf8-encode v][v] #{00}] ][ [#{00} v #{00}] ] ][ [#{08} int-to-ui8 (index? f) - 1] ] ] form-push-value: func[v][ switch/default type?/word v [ integer! [ either v = 0 [#{060000000000000000}][join #{07} int-to-ui32 v] ] decimal! [join #{06} decimal/to-native/flash v] string! [push-str-value v] tuple! [rejoin [#{07} head reverse to binary! v #{00}]] issue! [rejoin [#{07} head reverse issue-to-binary copy/part v 6 #{00}]] logic! [join #{05} either v [#{01}][#{00}]] binary! [v] ][push-str-value to string! v] ] form-push: func[ "Forms action-push tag" value /compact "used in SWF5" /nobuff /local b ][ either all [swf-version > 4 not nobuff][ append action-push-buff value ][ either block? value [ either compact [ b: make binary! 100 forall value [append b form-push-value value/1 ] form-act-tag #{96} b ][ foreach v value [form-push v]] ][ either swf-version > 4 [ form-act-tag #{96} form-push-value value ][ if number? value [value: mold value] form-act-tag #{96} rejoin [#{00} value #{00}] ] ] ] ] form-tag: func[ "Creates the SWF-TAG" id [integer!] "Tag ID" data [binary!] "Tag data block" /local i len ][ i: int-to-bits id 10 either any [ 62 < len: length? data found? find [2 20 34 36 37 48] id ] [ ;print ["Long tag:" len id] rejoin [ head reverse debase/base (join i "111111") 2 int-to-ui32 len data ] ][ ;print ["Short tag:" len id] ;prin [id data] ;probe head reverse debase/base (join i int-to-bits len 6) 2 rejoin [ head reverse debase/base (join i int-to-bits len 6) 2 data ] ] ] showFrame: func[][ foreach animation animations [ use [bin flags m a][ bin: make binary! 40 flags: make string! "00000001" ;m: select val2 'multiply ;a: select val2 'add ;if any [not none? a not none? m ][ ; insert bin bits-to-bin create-cxform/withalpha m a ; flags/5: #"1" ;] if all [block? animation/2 not tail? animation/2][ insert bin bits-to-bin create-matrix first animation/2 copy [rotate 0] flags/6: #"1" animation/2: next animation/2 ] insert bin int-to-ui16 animation/1 insert bin load rejoin ["2#{" flags "}"] ins form-tag 26 bin ] ; ] ;] ] ;streaming: if not none? stream [ if none? mp3/frame [ mp3/getMp3Frame stream/port ] if stream/MakeHead? [ ins create-soundStreamHead stream/MakeHead?: false ] either none? mp3/frame [ ;print ["end of stream at frame:" frames] close stream/port stream: none ][ create-soundStreamBlock ] ] ;--- if not empty? action-bin [ ins form-tag 12 join action-bin #{00} clear action-bin clear ConstantPool ] ;init classes for swf7: compile-classes ;--- ins form-tag 1 #{} frames: frames + 1 do-set-word frames + 1 ] create-cxform: func[ "Creates Color Transform Record (in bits)" mult [none! integer! tuple! block!] "Multiplication Transforms" addi [none! integer! tuple! block!] "Addition Transforms" /withalpha "Colors are with alpha channel" /local bl bits prep ][ if all [none? mult none? addi][return "00000100"] bits: make string! 64 bl: make block! 8 prep: func[v /local b l][ b: make block! 4 either integer? v [ insert/dup b v 3 ][ repeat i l: length? v [append b max min pick v i 256 -256] ] if all [withalpha l <> 4][append b 256] b ] insert bits either none? mult [#"0"][append bl prep mult #"1"] insert bits either none? addi [#"0"][append bl prep addi #"1"] head insert tail bits ints-to-sbs/complete bl 4 ] create-matrix: func[ transp [pair! block!] "Transposition offset" other [block!] "Scale and rotation info" /local bits v lx ly l scy scx sk0 sk1 ro sc ][ bits: make string! 64 scy: scx: 1 sk0: sk1: 0 if not none? ro: select other 'rotate [ if number? ro [ro: reduce [ro ro]] scx: cosine ro/1 scy: cosine ro/2 sk0: sine ro/1 sk1: negate sine ro/2 ] if not none? sc: select other 'scale [ if number? sc [sc: reduce [sc sc]] scx: scx * sc/1 scy: scy * sc/2 sk0: sk0 * sc/1 sk1: sk1 * sc/2 ] if not none? v: select other 'skew [ v: reduce either number? v [[v v]][[v/1 v/2]] v: reduce [v/1 / 360 v/2 / 360] sk0: sk0 + v/2 sk1: sk1 + v/1 ] if not none? v: select other 'reflect [ v: reduce either number? v [[v v]][[v/1 v/2]] scx: scx * v/1 scy: scy * v/2 ] append bits either any [scx <> 1 scy <> 1][ scx: int-to-FB scx scy: int-to-FB scy lx: length? scx ly: length? scy either lx > ly [ insert/dup scy scy/1 lx - ly l: lx ][ insert/dup scx scx/1 ly - lx l: ly ] rejoin [#"1" int-to-bits l 5 scx scy] ][ #"0" ] append bits either any [sk0 <> 0 sk1 <> 0][ sk0: int-to-FB sk0 sk1: int-to-FB sk1 lx: length? sk0 ly: length? sk1 either lx > ly [ insert/dup sk1 sk1/1 lx - ly l: lx ][ insert/dup sk0 sk0/1 ly - lx l: ly ] rejoin [#"1" int-to-bits l 5 sk0 sk1] ][ #"0" ] append bits either all [transp/1 = 0 transp/2 = 0]["00000"][ ints-to-sbs/complete [transp/1 transp/2] 5 ] ] create-rect: func [min-pos max-pos /bin /local rect][ rect: ints-to-sbs/complete [min-pos/x max-pos/x min-pos/y max-pos/y] 5 either bin [bits-to-bin rect][ rect ] ] compile-sprite: func[val val2 val3 /local spr][ either binary? val2 [ ins form-tag 39 rejoin [set-id val val2] ][ if word? val2 [ val2: compose [place (val2) showFrame end]] insert/only sprite-recursion-buff reduce [frames copy body] insert/only sprite-recursion-buff reduce [ copy action-bin copy set-word-buff last-depth ] clear action-bin clear set-word-buff last-depth: 0 frames: 0 body: make binary! 10000 compile val2 set [action-bin set-word-buff last-depth] first sprite-recursion-buff remove sprite-recursion-buff spr: rejoin [ set-id val int-to-ui16 frames body ] set [frames body] first sprite-recursion-buff remove sprite-recursion-buff ins form-tag 39 spr ;SWF6 DoInitAction: ;probe last-id ;probe val3 if not none? val3 [ doInitAction last-id val3 ] ] ] doInitAction: func[id val][ if not empty? action-bin [ ins form-tag 12 join action-bin #{00} clear action-bin clear ConstantPool ] either binary? val [ insert tail action-bin val ][ compile-actions val] insert action-bin either binary? id [id][int-to-ui16 get-id id] ;sprite id ins form-tag 59 join action-bin #{00} clear action-bin clear ConstantPool ] compile: func[data [block!] /rules rul][ parse data either rules [rul][tag-rules] ] create-header: func[version size rate frames][ rejoin [ #{465753} load rejoin ["#{0" version "}"] #{00000000} ;length of file create-rect/bin 0x0 size * 20 ;size #{00} int-to-ui8 rate ;rate int-to-ui16 frames ;frames ] ] create-swf: func[ size [pair!] "Size of the flash file in pixels!" content [block! binary!] /rate r /version v /compressed compressed? /local header swf tmp ][ init swf: make binary! 10000 swf-version: either version [v][4] swf-framerate: either rate [r][12] either binary? content [ body: content ][ compile content ] either compressed? [ tmp: rejoin [ create-rect/bin 0x0 size * 20 ;size #{00} int-to-ui8 swf-framerate ;rate int-to-ui16 frames ;frames body ] swf: rejoin [ #{435753} load rejoin ["#{0" swf-version "}"] int-to-ui32 8 + length? tmp compress tmp ;head remove/part tail compress tmp -4 ] ][ header: create-header swf-version size swf-framerate frames swf: rejoin [header body] ;now set the FileLength! change/part skip swf 4 int-to-ui32 length? swf 4 ] frames: 0 swf ] make-html: func[src size color][ if not issue? color [ parse mold to-binary color [thru "#{" copy color to "}"] ] id: copy last split-path to-file src replace/all id "." "_" rejoin [{ } src {
}] ] make-swf: func[ file [file! url!] "Dialect file co compile" /html "Will create a HTML file as well (only with the save switch!)" /save "Save result into file set in the rswf-header" /to out-file "if saving than into this file instead of the file set in the header" /compressed "Compressed swf file" /local bin data was-dir swf-file html-file f ][ if not exists? file [ either any [ exists? f: join file ".rswf" exists? f: join rswf-root-dir file exists? f: join rswf-root-dir [file ".rswf"] ][file: f][print ["Cannot found the file" file "!"] halt] ] data: load/header file switch/default data/1/type [ swf [swf-version: 4] swf5 [swf-version: 5] mx [swf-version: 6] mx2004 [swf-version: 7] ][ print { Probably not SWF dialect file (there is wrong type in the header -> should be 'swf, 'swf5, 'mx or 'mx2004)} halt ] was-dir: what-dir if error? try [change-dir data/1/base-dir][ change-dir first split-path file ] error? try [compressed: data/1/compressed] frames: 0 bin: create-swf/rate/version/compressed data/1/size next data data/1/rate swf-version compressed if all [data/1/file save][ write/binary swf-file: either to [out-file][data/1/file] bin if html [ html-file: append (copy/part swf-file ((length? swf-file) - 3)) "html" write/binary html-file make-html (last parse swf-file "/") data/1/size data/1/background ] ] change-dir was-dir bin ]