REBOL [ Title: "Rebol/Flash dialect (RSWF)" Date: 8-Oct-2007/17:07:07+2:00 Name: "rswf" Version: 2.5.0 File: %rswf.r Home: [http://oldes.multimedia.cz http://box.lebeda.ws/~hmm/] Author: "oldes" Owner: none Rights: { REBOL is a Trademark of REBOL Technologies Macromedia(r) and Flash(tm) are trademarks or registered trademarks of Macromedia, Inc. in the United States and/or other countries. Rebol and Macromedia as anybody else do not sponsor this product. You can freely use it (but not sell it), just let me know if you improve something and maybe if you use it for some interesting thing.} Needs: none Tabs: none Usage: { There are these methods how to make the swf file: ^-a) using 'create-swf ^-^-create-swf/rate 100x100 [dialect data] 20 ^-b) 'rswf/compile & 'create-swf ^-^-if the dialect data are dynamicly created, you can use: ^-^-rswf/init ^-^-loop 10 [ rswf/compile [some dialect] ] ^-^-create-swf 100x100 rswf/body ^-c) using 'make-swf ^-^-if the dialect is in special file... rate and size are in the header... ^-^-make-swf %flash-file.rswf ^-For examples of the dialect see: ^-http://box.lebeda.ws/~hmm/rswf/ } Purpose: { To create Flash file (SWF) using own Rebol dialect which is specified by the 'action and 'tag parsing rules.} Comment: { special thanks belongs to Ladislav Mecir for help with the new actions parser used since version 2.0.0 and Gabriele Santilli for help with the older parser (so I could start at least) Note, that even it's now version 2.0.0, it's not finished, there is still a lot of things to do. The main goal now is to finish correct usage of aDefineFunc2 action tag used since SWF7} History: [ 2.5.0 [8-Oct-2007 "oldes" [ {New swf-parser included which replaces old exam-swf function (useful for importing foreign SWF files)} {Added implementation of Class definitions for SWF versions 6 and higher} {Added new 'trace function into actions (which can be use to compile swf files with or without trace calls easily)} {'require and 'include now accepts block of files or urls} ]] 2.0.0 [13-Sep-2007 "oldes" [ "first public version with new actions parser" ]] 1.0.10 [21-Feb-2007 "oldes" [ "Implemented automatic ConstantPool conversion" ]] 1.0.9 [17-Feb-2007 "oldes" [ {Reviewed and fixed interpretations of "control flow" and finaly made correct interpretation of "breaks"} ]] 1.0.8 [31-May-2006 "oldes" [ {Fixed bug with missing 'pop' opcode after calling function inside 'if' block} ]] 1.0.7 [27-Mar-2006 "oldes" [ {Added missing stringEquals operator ( string1 eq string2 )} ]] 1.0.6 [17-Mar-2006 "oldes" [ {Added new tag rule used to override the default settings for maximum recursion depth and ActionScript time-out: 'ScriptLimits integer! integer!} ]] 1.0.5 [16-Mar-2006 "oldes" [ {Added new tag rule used to set local-with-networking flag: 'UseNetwork [on | off]} ]] 1.0.4 [18-Oct-2005 "oldes" [ {Review of import-swf function (part of the swf-importer object)} {Added new tag rule for swf import: 'impor-swf [file! | url!]} ]] 1.0.3 [13-Oct-2005 "oldes" [ "Added missing utf-8 encoding to ExportAssets names" {Quick review of extended-image code (but would like to make it again as it can be done better in the future)} {Fixed conversion of 4digit-issues (for example #00FF0000 where the first byte is alpha channel)} ]] 1.0.2 [12-Oct-2005 "oldes" [ {Improved download of includes and other parts of the code from the web site} {Added shortcuts for making flash8 internal objects - for example: ^-make ColorMatrixFilter! [matrix] instead of: ^-make flash.filters.ColorMatrixFilter [matrix] Check this example for complete list of shortcuts: http://box.lebeda.ws/~hmm/rswf/index.php?example=swf8-colormatrix} {Added rswf/string-replace-pairs variable for possibility to modify strings during compilation} ]] 1.0.1 [7-Oct-2005 "oldes" [ {Fixed bug in 'process-for function for swf4 version} {Included experimental 'extended-image and 'make-window functions} ]] 1.0.0 [5-Oct-2005 "oldes" [ "Enhanced 'place tag to accept Flash8 blending" "Builded with ucs-2 support for CP1250 charset only" ]] 0.9.5 [4-Oct-2005 "oldes" [ {Modified the 'process-for function to produce code more consistent with Flash's 'for cycles} ]] 0.9.5 [20-Sep-2005 "oldes" [ "Fixed bug in ints-to-sbs function." ]] 0.9.4 [5-Jun-2005 "oldes" [ "Fixed bug in process-while loop function" ]] 0.9.3 [19-Apr-2005 "oldes" [ {Changed twips conversion: moved the twips? value and to-twips from 'shape compilation into rswf values. Now I can set that placeObject is using twips values as well. I'm not checking the other values as I don't need them at this moment.} ]] 0.9.2 [19-Aug-2004 "oldes" [ "Various fixes" "New action command 'reform" {New shape: box rounded 10 only [1 2] 0x0 100x100 ;this will create box with only top corners rounded} ]] 0.9.0 [15-Mar-2004 "oldes" "All in one file release"] 0.0.3 [21-Nov-2001 "oldes" "First release"] ] Language: none Type: none Content: none Email: oliva.david@seznam.cz Category: [file util 4] require: none preprocess: true ] comment { #### RS include: %jpg-analyse.r #### Title: "JPG analyse" #### Author: "Oldes" ----} jpg-analyse: func [ {Analyses the JPG file and tries to remove some unnecessary infos from file} file [file! url! binary!] "JPG file to analyse" /remove tags-to-remove [block!] {If not specified these tags are removed: ^-^-^-["Photoshop 3.0" "ICC_PROFILE" "Adobe" "Ducky"] if presents} /quiet "Will not print informations" /local img to-int buf newimg jfif version units Xdensity Ydensity Xthumbnail Ythumbnail rgb length lng identifier data APP0 m msg ] [ if not remove [ tags-to-remove: [ "Photoshop 3.0" "ICC_PROFILE" "Adobe" "Ducky" "Exif" ] ] img: either binary? file [file] [read/binary file] newimg: make binary! length? img to-int: func [i] [to-integer to-binary i] msg: func [m] [if not quiet [print m]] JFIF: [ ["JFIF^@" copy version 2 skip ( version: (to-int version/1) + ((to-int version/2) / 100) ) copy units 1 skip (units: to-int units) copy Xdensity 2 skip copy Ydensity 2 skip copy Xthumbnail 1 skip copy Ythumbnail 1 skip copy rgb to end ] ( print "JFIF HEADER:" print ["^- version:" version] print ["^- units:" pick [ "no units, X and Y specify the pixel aspect ratio" "X and Y are dots per inch" "X and Y are dots per cm" ] 1 + units ] print ["^- density:" to-pair reduce [to-int Xdensity to-int Ydensity]] print ["^-thumbnail:" to-pair reduce [ to-int Xthumbnail to-int Ythumbnail ] ] ) ] parse/all img [ copy buf thru "˙Ř" (insert tail newimg buf) some [ "˙" [ #"Ů" ( insert tail newimg #"Ů" print "End of Image" ) opt [copy buf thru "˙Ř" (insert tail newimg buf)] | copy APP0 1 skip copy length 2 skip (lng: (to-int length) - 2) copy data lng skip ( if not quiet [ print either none? m: select [ #{C0} "Start Of Frame 0" #{DA} "Start Of Scan" #{E0} "JPG file which uses the JFIF" #{FE} "Comment" #{DC} "Define Number of Lines" #{DD} "Define Restart Interval" #{DB} "Define Quantization Table" #{C4} "Define Huffman Table" #{D9} "End of Image" ] to-binary APP0 [ [mold to-binary APP0 "unknown marker"] ] [[mold to-binary APP0 m]] ] identifier: none either APP0 = "ŕ" [ if not quiet [parse/all data JFIF] ] [ if not none? data [ parse/all data [ copy identifier to "^@" 1 skip to end ] ] ] either any [ found? find tags-to-remove identifier APP0 = "ţ" ] [ msg either none? identifier [ ["Removed data:" data] ] [ ["Removed tag" mold identifier "lenght:" lng + 4] ] ] [ insert tail newimg rejoin ["˙" APP0 length data] ] ) ] ] copy buf to end (insert tail newimg buf) ] msg ["Original image:" length? img "B"] msg ["Optimised image:" length? newimg "B"] newimg ] replace-jpgs: func [ "Replaces all JPG files" /dir path /local tsz1 tsz2 sz1 sz2 ext img newimg modes ] [ if not dir [ path: to-file ask "Directory? " ] if empty? path [path: %./] if (last path) <> #"/" [append path #"/"] if not exists? path [print [path "does not exist"] halt] tsz1: 0 tsz2: 0 foreach file files: read path [ either dir? path/:file [ foreach newfile read path/:file [append files file/:newfile] ] [ ext: last (parse mold path/:file ".") if ext = "jpg" [ if error? try [ img: read/binary path/:file modes: get-modes path/:file [modification-date owner-write] if not last modes [ ] sz1: length? img newimg: jpg-analyse/quiet img sz2: length? newimg tsz1: tsz1 + sz1 tsz2: tsz2 + sz2 if sz1 > sz2 [ write/binary path/:file newimg set-modes path/:file modes print [path/:file sz1 sz2] ] ] [print ["ERROR: " path/:file]] ] ] ] print ["Before: " tsz1] print ["Now: " tsz2] print ["Removed:" tsz1 - tsz2] ] comment "---- end of RS include %jpg-analyse.r ----" comment { #### RS include: %ucs2cp1250.r #### Title: "UCS-2 (CP1250 charset only!)" #### Author: "oldes" ----} ucs2: context [ charmap: "cp1250" result: c: none encode-rule: [ any [ #{82} (insert tail result #{201A}) | #{84} (insert tail result #{201E}) | #{85} (insert tail result #{2026}) | #{86} (insert tail result #{2020}) | #{87} (insert tail result #{2021}) | #{89} (insert tail result #{2030}) | #{8A} (insert tail result #{0160}) | #{8B} (insert tail result #{2039}) | #{8C} (insert tail result #{015A}) | #{8D} (insert tail result #{0164}) | #{8E} (insert tail result #{017D}) | #{8F} (insert tail result #{0179}) | #{91} (insert tail result #{2018}) | #{92} (insert tail result #{2019}) | #{93} (insert tail result #{201C}) | #{94} (insert tail result #{201D}) | #{95} (insert tail result #{2022}) | #{96} (insert tail result #{2013}) | #{97} (insert tail result #{2014}) | #{99} (insert tail result #{2122}) | #{9A} (insert tail result #{0161}) | #{9B} (insert tail result #{203A}) | #{9C} (insert tail result #{015B}) | #{9D} (insert tail result #{0165}) | #{9E} (insert tail result #{017E}) | #{9F} (insert tail result #{017A}) | #{A1} (insert tail result #{02C7}) | #{A2} (insert tail result #{02D8}) | #{A3} (insert tail result #{0141}) | #{A5} (insert tail result #{0104}) | #{AA} (insert tail result #{015E}) | #{AF} (insert tail result #{017B}) | #{B2} (insert tail result #{02DB}) | #{B3} (insert tail result #{0142}) | #{B9} (insert tail result #{0105}) | #{BA} (insert tail result #{015F}) | #{BC} (insert tail result #{013D}) | #{BD} (insert tail result #{02DD}) | #{BE} (insert tail result #{013E}) | #{BF} (insert tail result #{017C}) | #{C0} (insert tail result #{0154}) | #{C3} (insert tail result #{0102}) | #{C5} (insert tail result #{0139}) | #{C6} (insert tail result #{0106}) | #{C8} (insert tail result #{010C}) | #{CA} (insert tail result #{0118}) | #{CC} (insert tail result #{011A}) | #{CF} (insert tail result #{010E}) | #{D0} (insert tail result #{0110}) | #{D1} (insert tail result #{0143}) | #{D2} (insert tail result #{0147}) | #{D5} (insert tail result #{0150}) | #{D8} (insert tail result #{0158}) | #{D9} (insert tail result #{016E}) | #{DB} (insert tail result #{0170}) | #{DE} (insert tail result #{0162}) | #{E0} (insert tail result #{0155}) | #{E3} (insert tail result #{0103}) | #{E5} (insert tail result #{013A}) | #{E6} (insert tail result #{0107}) | #{E8} (insert tail result #{010D}) | #{EA} (insert tail result #{0119}) | #{EC} (insert tail result #{011B}) | #{EF} (insert tail result #{010F}) | #{F0} (insert tail result #{0111}) | #{F1} (insert tail result #{0144}) | #{F2} (insert tail result #{0148}) | #{F5} (insert tail result #{0151}) | #{F8} (insert tail result #{0159}) | #{F9} (insert tail result #{016F}) | #{FB} (insert tail result #{0171}) | #{FE} (insert tail result #{0163}) | #{FF} (insert tail result #{02D9}) | copy c 1 skip (insert tail result join #{00} c) ] ] decode-rule: [ any [ #{201A} (insert tail result #{82}) | #{201E} (insert tail result #{84}) | #{2026} (insert tail result #{85}) | #{2020} (insert tail result #{86}) | #{2021} (insert tail result #{87}) | #{2030} (insert tail result #{89}) | #{0160} (insert tail result #{8A}) | #{2039} (insert tail result #{8B}) | #{015A} (insert tail result #{8C}) | #{0164} (insert tail result #{8D}) | #{017D} (insert tail result #{8E}) | #{0179} (insert tail result #{8F}) | #{2018} (insert tail result #{91}) | #{2019} (insert tail result #{92}) | #{201C} (insert tail result #{93}) | #{201D} (insert tail result #{94}) | #{2022} (insert tail result #{95}) | #{2013} (insert tail result #{96}) | #{2014} (insert tail result #{97}) | #{2122} (insert tail result #{99}) | #{0161} (insert tail result #{9A}) | #{203A} (insert tail result #{9B}) | #{015B} (insert tail result #{9C}) | #{0165} (insert tail result #{9D}) | #{017E} (insert tail result #{9E}) | #{017A} (insert tail result #{9F}) | #{02C7} (insert tail result #{A1}) | #{02D8} (insert tail result #{A2}) | #{0141} (insert tail result #{A3}) | #{0104} (insert tail result #{A5}) | #{015E} (insert tail result #{AA}) | #{017B} (insert tail result #{AF}) | #{02DB} (insert tail result #{B2}) | #{0142} (insert tail result #{B3}) | #{0105} (insert tail result #{B9}) | #{015F} (insert tail result #{BA}) | #{013D} (insert tail result #{BC}) | #{02DD} (insert tail result #{BD}) | #{013E} (insert tail result #{BE}) | #{017C} (insert tail result #{BF}) | #{0154} (insert tail result #{C0}) | #{0102} (insert tail result #{C3}) | #{0139} (insert tail result #{C5}) | #{0106} (insert tail result #{C6}) | #{010C} (insert tail result #{C8}) | #{0118} (insert tail result #{CA}) | #{011A} (insert tail result #{CC}) | #{010E} (insert tail result #{CF}) | #{0110} (insert tail result #{D0}) | #{0143} (insert tail result #{D1}) | #{0147} (insert tail result #{D2}) | #{0150} (insert tail result #{D5}) | #{0158} (insert tail result #{D8}) | #{016E} (insert tail result #{D9}) | #{0170} (insert tail result #{DB}) | #{0162} (insert tail result #{DE}) | #{0155} (insert tail result #{E0}) | #{0103} (insert tail result #{E3}) | #{013A} (insert tail result #{E5}) | #{0107} (insert tail result #{E6}) | #{010D} (insert tail result #{E8}) | #{0119} (insert tail result #{EA}) | #{011B} (insert tail result #{EC}) | #{010F} (insert tail result #{EF}) | #{0111} (insert tail result #{F0}) | #{0144} (insert tail result #{F1}) | #{0148} (insert tail result #{F2}) | #{0151} (insert tail result #{F5}) | #{0159} (insert tail result #{F8}) | #{016F} (insert tail result #{F9}) | #{0171} (insert tail result #{FB}) | #{0163} (insert tail result #{FE}) | #{02D9} (insert tail result #{FF}) | #{00} copy c 1 skip (insert tail result c) | copy c 2 skip (decodeUnknownChar c) ] ] encode: func [ {Encodes any text to UCS-2 octet string acording the charset} str [string! binary!] "String to encode" ] [ str: to-binary str result: make binary! 2 * length? str parse/all/case str encode-rule result ] decode: func [ {Decodes any text to UCS-2 octet string acording the charset} str [string! binary!] "String to encode" ] [ result: make binary! 2 * length? str parse/all/case str decode-rule result ] ] comment "---- end of RS include %ucs2cp1250.r ----" comment { #### RS include: %utf-8.r #### Title: "UTF-8" #### Author: "Jan Skibinski" ----} comment { UCS means: Universal Character Set (or Unicode) UCS-2 means: 2-byte representation of a character in UCS. UCS-4 means: 4-byte representation of a character in UCS. UTF-8 means: UCS Transformation Format using 8-bit octets. The following excerpt from: UTF-8 and Unicode FAQ for Unix/Linux, by Markus Kuhn http://www.cl.cam.ac.uk/~mgk25/unicode.html provides motivations for using UTF-8. <> The copy of forementioned Annex D can be found on Markus site: http://www.cl.cam.ac.uk/~mgk25/ucs/ISO-10646-UTF-8.html. Encoding and decoding functions implemented here are based on the descriptions of algorithms found in the Annex D. Testing: The page http://www.cl.cam.ac.uk/~mgk25/unicode.html has many pointers to variety of test data. One of them is a UTF-8 sampler from Kermit pages of Columbia University http://www.columbia.edu/kermit/utf8.html, where the phrase "I can eat glass and it doesn't hurt me." is produced in dozens of world languages. A shareware unicode editor 'EmEditor, from www.emurasoft.com can be used for copying, editing and saving unicode samples from the web browsers. Since it saves its output in UCS-2, UCS-4 (big and little endians), UTF-8 and UTF-7 formats it is a very good tool for testing. } comment { ------------------------------------------------------------ SUMMARY of script UTF-8.R ------------------------------------------------------------ decode-2 (binary -> binary) encode-2 (binary -> binary) decode-4 (binary -> binary) encode-4 (binary -> binary) decode-integer (binary -> [integer integer]) encode-integer (integer -> binary) } utf-8: context [ allchars: complement charset [] encode-2: func [ { Encode a binary string of UCS-2 octets into a UTF-8 encoded binary octet stream. } us [binary! string!] /local x result [binary!] ] [ us: to-binary us result: copy #{} while [not tail? us] [ x: (256 * first us) + second us insert tail result encode-integer x us: skip us 2 ] result ] encode-4: func [ { Encode a binary string of UCS-4 octets into a UTF-8 encoded binary octet stream. } us [binary! string!] /local x result [binary!] ] [ us: to-binary us result: copy #{} while [not tail? us] [ x: (16777216 * first us) + (65536 * second us) + (256 * third us) + fourth us insert tail result encode-integer x us: skip us 4 ] result ] decode-2: func [ { Decode a UTF-8 encoded binary string to a UCS-2 binary string } xs [binary! string!] /local z vs us result [binary!] ] [ xs: to-binary xs result: copy #{} while [not tail? xs] [ us: decode-integer xs vs: copy [] z: to integer! ((first us) / 256) insert vs z z: (first us) - (z * 256) insert tail vs z insert tail result to binary! vs xs: skip xs second us ] result ] decode-4: func [ { Decode a UTF-8 encoded binary string to UCS-4 binary string } xs [binary! string!] /local z1 z vs us result [binary!] ] [ xs: to-binary xs result: copy #{} while [not tail? xs] [ us: decode-integer xs vs: copy [] z: us/1 foreach k [16777216 65536 256] [ z1: to integer! (z / :k) insert tail vs z1 z: z - (z1 * :k) ] insert tail vs z insert tail result to binary! vs xs: skip xs second us ] result ] encode-integer: func [ { Encode 4-byte (32-bit) UCS-4 integer to a sequence of UTF-8 octets. } [throw] x [integer!] /local f k result [binary!] ] [ k: 1 loop 6 [ if x <= encases/:k [ result: to binary! enf :k x break ] k: k + 1 ] result ] decode-integer: func [ { Decode sequence of 1-6 octets into 32-bit unsigned integer. Return a pair made of a decoded integer and a count of bytes used from the input string. } xs [binary!] /local f k result [block!] ] [ k: 1 loop 6 [ if (first xs) <= pick decases k [ result: to block! def :k xs insert tail result :k break ] k: k + 1 ] result ] enf: func [ k x /local result ] [ result: to block! (us/:k + to integer! (x / vs/:k)) if k > 1 [ for z (k - 1) 1 -1 [ insert tail result ( (to integer! (x / vs/:z)) // 64 + 128 ) ] ] result ] def: func [ k xs /local m result ] [ result: ((first xs) - us/:k) * vs/:k if k >= 2 [ for z 2 k 1 [ m: k - :z + 1 result: result + ((xs/:z - 128) * vs/:m) ] ] result ] us: [0 192 224 240 248 252] vs: [1 64 4096 262144 16777216 1073741824] encases: [ 127 2047 65535 2097151 67108863 2147483647 ] decases: [127 223 239 247 251 253] ] comment "---- end of RS include %utf-8.r ----" comment { #### RS include: %ieee.r #### Title: "IEEE convertors" #### Author: {Piotr Gapinski, Larry Palmiter, Gerald Goertzel, Oldes} ----} ieee: context [ to32: context [ ieee-sign: func [dat] [either positive? dat [0] [1]] ieee-exponent: func [dat /local weight i] [ dat: to integer! dat weight: 8388608 i: 0 forever [ i: i + 1 if ((weight and dat) = weight) [break] weight: to integer! (weight / 2) ] 24 - i + 127 ] ieee-mantissa: func [dat e /local m] [ m: to integer! (dat * (power 2 (23 - e + 127))) m: m and 8388607 ] set 'to-ieee32 func [ {Converts decimal! or integer! to ieee-32bit binary! format.} [catch] dat [number!] "value to convert (24 bits)" /local s e m ] [ s: ieee-sign dat dat: abs dat e: ieee-exponent dat m: ieee-mantissa dat e debase/base to-hex (to integer! (m + (e * power 2 23) + (s * power 2 31))) 16 ] ] from32: context [ ieee-sign: func [dat] [either zero? ((to integer! dat) and -2147483648) [1] [-1]] ieee-exponent: func [dat /local exp] [ exp: (to integer! dat) and 2139095040 exp: (exp / power 2 23) - 127 ] ieee-mantissa: func [dat] [ ((to integer! dat) and 8388607) + (to integer! (1 * power 2 23)) ] set 'from-ieee32 func [ "Converts binary float ieee-32 to number!" [catch] dat [binary!] "data to convert" ] [ (ieee-sign dat) * (to integer! ieee-mantissa dat) / power 2 (23 - (ieee-exponent dat)) ] ] ieee64: context [ split: func [ {Returns block containing three components of double floating point value} x [number!] /local sign exponent fraction ] [ sign: either negative? x [x: (- x) 1] [0] either zero? x [exponent: 0 fraction: 0] [ either zero? 1024 - exponent: to integer! log-2 x [exponent: 1023] [ if positive? (2 ** exponent) - x [exponent: exponent - 1] ] fraction: x / (2 ** exponent) either positive? exponent: exponent + 1023 [ fraction: fraction - 1 fraction: fraction * (2 ** 52) ] [ fraction: 2 ** (51 + exponent) * fraction exponent: 0 ] ] reduce [sign exponent fraction] ] set 'to-ieee64 func [ {convert a numerical value into native binary format} x [number!] /flash "returns flash byte order" /local out sign exponent fraction byte ] [ set [sign exponent fraction] split x out: make binary! 8 loop 6 [ insert out to char! byte: fraction // 256 fraction: fraction - byte / 256 ] insert out to char! exponent // 16 * 16 + fraction insert out to char! exponent / 16 + (128 * sign) either flash [ out: head reverse out insert tail out copy/part out 4 return remove/part out 4 ] [ return either rev [head reverse out] [out] ] ] set 'from-ieee64 func [ {convert a binary native into a decimal value (64bit)} in [binary!] /flash /local sign exponent fraction ] [ in: copy in if flash [ insert tail in copy/part in 4 in: head reverse remove/part in 4 ] sign: either 0 = ((first in) and 128) [1] [-1] exponent: (first in) // 128 * 16 + to integer! (second in) / 16 fraction: to decimal! (second in) // 16 in: skip in 2 loop 6 [ fraction: fraction * 256 + first in in: next in ] sign * either zero? exponent [ 2 ** -1074 * fraction ] [ 2 ** (exponent - 1023) * (2 ** -52 * fraction + 1) ] ] ] ] comment "---- end of RS include %ieee.r ----" comment { #### RS include: %acompiler.r #### Title: "Acompiler" #### Author: "David Oliva" ----} utf8-encode: func [ "Encodes the string data to UTF-8" str [any-string!] "string to encode" /local c ] [ utf-8/encode-2 ucs2/encode str ] acompiler: context [ comment { #### Include: %conversions.r #### Title: "" #### Author: "" ----} 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] ] [ 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] ] issue-to-binary: func [clr] [debase/base clr 16] issue-to-decimal: func [i [issue!] /local e d] [ i: head reverse issue-to-binary i e: 0 d: 0 forall i [ d: d + (i/1 * (2 ** e)) e: e + 8 ] d ] tuple-to-decimal: func [t [tuple!] /local e d] [ t: head reverse to-binary t e: 0 d: 0 forall t [ d: d + (t/1 * (2 ** e)) e: e + 8 ] d ] comment "---- end of include %conversions.r ----" comment { #### Include: %actionids.r #### Title: "" #### Author: "" ----} local-constants: make hash! [ 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 PI 3.14159265358979 ] properties: make hash! [ _x 0 _y 1 _xscale 2 _yscale 3 _currentframe 4 _totalframes 5 _alpha 6 _visible 7 _width 8 _height 9 _rotation 10 _target 11 _framesloaded 12 _name 13 _droptarget 14 _url 15 _highquality 16 _focusrect 17 _soundbuftime 18 _quality 19 _xmouse 20 _ymouse 21 ] path-shortcuts: make hash! [ Date! Date Color! Color BitmapFilter! flash.filters.BitmapFilter BevelFilter! flash.filters.BevelFilter BlurFilter! flash.filters.BlurFilter ColorMatrixFilter! flash.filters.ColorMatrixFilter ConvolutionFilter! flash.filters.ConvolutionFilter DisplacementMapFilter! flash.filters.DisplacementMapFilter DropShadowFilter! flash.filters.DropShadowFilter GlowFilter! flash.filters.GlowFilter GradientBevelFilter! flash.filters.GradientBevelFilter GradientGlowFilter! flash.filters.GradientGlowFilter BitmapData! flash.display.BitmapData ColorTransform! flash.geom.ColorTransform Matrix! flash.geom.Matrix Point! flash.geom.Point Rectangle! flash.geom.Rectangle Transform! flash.geom.Transform ExternalInterface! flash.external.ExternalInterface FileReference! flash.net.FileReference FileReferenceList! flash.net.FileReferenceList Locale! mx.lang.Locale TextRenderer! flash.text.TextRenderer ] actionIds: make hash! [ aEnd #{00} aNextFrame #{04} aPrevFrame #{05} aPlay #{06} aStop #{07} aToggleQuality #{08} aStopSounds #{09} aGotoFrame #{81} aGetURL #{83} aWaitForFrame #{8A} aSetTarget #{8B} aGoToLabel #{8C} aPush #{96} aPop #{17} aAdd #{0A} aSubtract #{0B} aMultiply #{0C} aDivide #{0D} aEquals #{0E} aLess #{0F} aAnd #{10} aOr #{11} aNot #{12} aStringEquals #{13} aStringLength #{14} aStringAdd #{21} aStringExtract #{15} aStringLess #{29} aMBStringLength #{31} aMBStringExtract #{35} aToInteger #{18} aCharToAscii #{32} aAsciiToChar #{33} aMBCharToAscii #{36} aMBAsciiToChar #{37} aJump #{99} aIf #{9D} aCall #{9E} aGetVariable #{1C} aSetVariable #{1D} aGetURL2 #{9A} aGotoFrame2 #{9F} aSetTarget2 #{20} aGetProperty #{22} aSetProperty #{23} aCloneSprite #{24} aRemoveSprite #{25} aStartDrag #{27} aEndDrag #{28} aWaitForFrame2 #{8D} aTrace #{26} aGetTime #{34} aRandomNumber #{30} aCallFunction #{3D} aCallMethod #{52} aConstantPool #{88} aDefineFunction #{9B} aDefineLocal #{3C} aDefineLocal2 #{41} aDefineObject #{43} aDelete #{3A} aDelete2 #{3B} aEnumerate #{46} aEquals2 #{49} aGetMember #{4E} aInitArray #{42} aNewMethod #{53} aNewObject #{40} aSetMember #{4F} aTargetPath #{45} aWith #{94} aToNumber #{4A} aToString #{4B} aTypeOf #{44} aAdd2 #{47} aLess2 #{48} aModulo #{3F} aBitAnd #{60} aBitLShift #{63} aBitOr #{61} aBitRShift #{64} aBitURShift #{65} aBitXor #{62} aDecrement #{51} aIncrement #{50} aPushDuplicate #{4C} aReturn #{3E} aStackSwap #{4D} aStoreRegister #{87} aInstanceOf #{54} aEnumerate2 #{55} aStrictEqual #{66} aGreater #{67} aStringGreater #{68} aExtends #{69} aThrow #{2A} aCastOp #{2B} aImplementsOp #{2C} aDefineFunction2 #{8E} aTry #{8F} ] comment "---- end of include %actionids.r ----" utf8-encode?: true swf-version: 8 used-strings: make hash! 400 constantPool: copy [] useConstantPool?: true noFunc2?: true trace?: true slash: to-lit-word first [/] dslash: to-lit-word "//" rShift: to-lit-word ">>" UrShift: to-lit-word ">>>" _greater: to-lit-word ">" _less: to-lit-word "<" _noteql: to-lit-word "<>" _lesseql: to-lit-word "<=" _greatereql: to-lit-word ">=" lShift: ['left 'shift] ch_digits: charset "0123456789" ch_paren-start: charset "(" ch_paren-end: charset ")" ch_parens: union ch_paren-start ch_paren-end ch_separator: charset [#"/" #"."] ch_label: complement union ch_separator ch_parens ch_content: complement ch_parens rl_path-expression: [ch_paren-start any [ch_content | rl_path-expression] ch_paren-end] debug: none labels: 0 with-depth: 0 break-labels: copy [] flat-block: func ["Makes from array of blocks a flat one" b [block!]] [ while [not tail? b] [b: change/part b b/1 1] b: head b ] localVars: copy [] preloadVars: ["this" "arguments" "super" "_root" "_parent" "_global"] defineLocals: func [locals] [ if useRegisters? [ print ["defineLocals:" mold localVars mold locals] insert/only tail localVars locals ] ] clearLocals: does [ if useRegisters? [ print ["clearLocals:" mold localVars] remove back tail localVars ] ] setRegister: func [reg] [ either empty? registers [ insert/only registers reduce [reg] ] [ if none? find last registers reg [insert tail last registers reg] ] reg ] isLocal?: func [var] [all [ not empty? localVars find last localVars to-string var ]] setLocal: func [var] [ error? try [if none? isLocal? var [insert tail last localVars form var]] ] preloadVar?: func [var] [ either all [ not empty? localVars find preloadVars var ] [setLocal var true] [false] ] make-error!: func [errmsg pos] [ throw make error! reform [errmsg "^/** Code:" copy/part mold pos 100] ] make-warning!: func [msg pos] [ print reform ["** WARNING:" msg "^/** Code:" copy/part mold pos 100] ] useRegisters?: false translate: func [ [catch] code [block!] /do-not-pop /flat {returns result as a one block even if there is more of them} /store {do not remove stored register so the value can be reused} /local stack push pop expr codepos results mv1 mv2 mv3 pos ] [ if empty? code [return copy []] stack: copy [] results: copy [] push: func ["přidej na zásobník" mv] [ insert/only tail stack mv ] pop: func ["vyber ze zásobníku" /local vysl] [ vysl: last stack clear back tail stack vysl ] addPostAct: func [Act] [ mv2: pop mv1: pop push head insert tail insert tail mv1 mv2 Act ] addUnaryAct: func [Act] [ push head insert tail pop Act ] new-label: func [] [to-word join "L" labels: labels + 1] count-str: func [str /local n] [ either none? n: find/tail/case used-strings str [ repend used-strings [str 1] ] [change n (n/1 + 1)] ] finishExpression: func [/local res p] [ either error? try [res: pop] [res: none] [ if not empty? res [ if none? store [ p: last res switch p [ aStoreSetGetVariable [change back tail res 'aSetVariable] aStoreSetLocalGetVariable [change back tail res 'aDefineLocal] aStoreSetGetMember [change back tail res 'aSetMember] aStoreSetGetProperty [change back tail res 'aSetProperty] aSetGetVariable [change back tail res 'aSetVariable] aSetLocalGetVariable [change back tail res 'aDefineLocal] aSetGetMember [change back tail res 'aSetMember] aSetGetProperty [change back tail res 'aSetProperty] aGetRegister [clear back tail res] ] ] if all [ not do-not-pop none? find [aSetVariable aSetMember aSetProperty aDefineLocal aDefineLocal2 aStop aReturn aPop] last res none? find [end aJump aSetTarget] pick tail res -2 'aGetURL <> pick tail res -3 ] [ insert tail res 'aPop ] ] either flat [ insert tail results res ] [insert/only tail results res] ] res ] trans-SetWordOrMember: func [/local pre tmp mv1 mv2 word first? asLocal] [ mv2: pop mv1: head reverse pop pre: copy [] first?: true parse mv1 [ some [ (asLocal: false) set word [set-word! | set-path!] opt ['var ( setLocal first parse form word "./" asLocal: true )] ( tmp: trans-GetWordOrPath either set-path? word [ head remove back tail form word ] [word] either all [ 'aGetRegister = first tmp 3 > length? tmp ] [ insert tail mv2 reduce ['aSetRegister tmp/2] insert pre remove/part tmp 2 ] [ lastAction: last tmp insert pre head remove back tail tmp switch/default lastAction [ aGetVariable [ either any [asLocal isLocal? mv1] [ either first? [ insert tail mv2 'aStoreSetLocalGetVariable first?: false ] [ insert tail mv2 'aSetLocalGetVariable ] ] [ either first? [ insert tail mv2 'aStoreSetGetVariable first?: false ] [ insert tail mv2 'aSetGetVariable ] ] ] aGetProperty [ either first? [ insert tail mv2 'aStoreSetGetProperty first?: false ] [ insert tail mv2 'aSetGetProperty ] ] ] [ either first? [ insert tail mv2 'aStoreSetGetMember first?: false ] [ insert tail mv2 'aSetGetMember ] ] ] ) ] ] insert mv2 pre push mv2 ] trans-SetEvalWord: func [/local pre word first?] [ mv2: pop mv1: head reverse pop pre: copy [] first?: true parse mv1 [some [ set word block! ( insert pre word either first? [ insert tail mv2 'aStoreSetGetVariable first?: false ] [ insert tail mv2 'aSetGetVariable ] ) ]] insert mv2 pre push mv2 ] trans-GetWordOrPath: func [wordOrPath /local pre result here there var c first? *crement] [ first?: true either any [ error? try [wordOrPath: to-word wordOrPath] none? prop: select properties wordOrPath ] [ result: copy [] parse/all form wordOrPath [some [ ch_separator | here: some [ch_label] there: ( var: copy/part here there if not none? *crement [ make-error! "Using (in|de)crement inside path" pos ] if not parse/all var [ ":" copy var to end ( if none? var [make-error! "Imvalid 'get-word!" pos] count-str var insert tail result var insert tail result reduce either first? [ first?: false ['aGetVariable 'aGetVariable] ] [ ['aGetVariable 'aGetMember] ] ) | ["++" (*crement: 'aIncrement) | "--" (*crement: 'aDecrement)] copy var to end ( if none? var [make-error! "Nothing to (in|de)crement" pos] count-str var insert tail result var insert tail result result insert tail result reduce either first? [ first?: false ['aGetVariable *crement 'aStoreSetGetVariable] ] [ ['aGetMember *crement 'aStoreSetGetMember] ] ) | copy var [to "++" (*crement: 'aIncrement) | to "--" (*crement: 'aDecrement)] 2 skip end ( if none? var [ make-error! "Nothing to (in|de)crement" pos ] count-str var insert tail result var tmp: copy result if not empty? stack [ insert tail result 'aGetVariable insert tail result tmp ] insert tail result tmp insert tail result reduce either first? [ first?: false ['aGetVariable *crement 'aSetVariable] ] [ ['aGetMember *crement 'aSetMember] ] ) ] [ if error? try [var: -1 + to integer! var] [ count-str var ] insert tail result reduce either first? [ first?: false either all [ useRegisters? any [ preloadVar? var isLocal? var ] ] [ ['aGetRegister var] ] [[var 'aGetVariable]] ] [ [var 'aGetMember] ] ] ) | here: rl_path-expression there: ( insert tail result trans-paren/store copy/part here there insert tail result 'aGetMember ) ]] ] [ result: reduce either with-depth > 0 [ [form wordOrPath 'aGetVariable] ] [['none prop 'aGetProperty]] ] result ] trans-callFunction: func [wordOrPath args /local result numArgs arg] [ result: copy [] args: head reverse to block! args parse/all args [ any [ set arg lit-word! (insert tail result select local-constants arg) | 'false (insert tail result reduce ['false]) | 'true (insert tail result reduce ['true]) | 'null (insert tail result reduce ['null]) | set arg [word! | path!] (insert tail result trans-GetWordOrPath arg) | set arg paren! (insert tail result trans-paren arg) | set arg any-type! (insert tail result reduce [arg]) ] ] insert tail result reduce [length? args] insert tail result trans-GetWordOrPath wordOrPath either 'aGetVariable = last result [ change back tail result 'aCallFunction ] [change back tail result 'aCallMethod] result ] trans-paren: func [val /store /local mv1 lastAction] [ mv1: copy [] foreach sub-result translate to-block val [ insert tail mv1 sub-result ] either 'aPop = lastAction: last mv1 [remove back tail mv1] [ if any [store not empty? stack] [ switch lastAction [ aSetVariable [change back tail mv1 'aStoreSetGetVariable] aSetMember [change back tail mv1 'aStoreSetGetMember] aSetProperty [change back tail mv1 'aStoreSetGetProperty] ] ] ] mv1 ] trans-if: func [condition block /local result label] [ result: translate/flat/store condition if 'aPop = last result [remove back tail result] label: new-label insert tail result reduce ['aNot 'aIf label] insert tail result translate/flat block insert tail result reduce ['end label] result ] trans-either: func [condition true-block false-block /local result label1 label2] [ label1: new-label label2: new-label result: translate/flat/store condition if 'aPop = last result [remove back tail result] insert tail result reduce ['aNot 'aIf label1] insert tail result translate/flat true-block insert tail result reduce ['aJump label2 'end label1] insert tail result translate/flat false-block insert tail result reduce ['end label2] result ] trans-switch: func [ value cases /default case /local result value-translated case-translated case-value case-action switchend label ] [ value-translated: translate/flat/store value either 'aPop = last value-translated [ remove back tail value-translated ] [ make-error! "SWITCH is missing its value argument" pos ] result: copy [] switchend: new-label parse cases [ some [ copy case-value to block! set case-action block! ( case-translated: translate/flat/store case-value either 'aPop = last case-translated [ label: new-label insert tail result value-translated insert tail result head remove back tail case-translated insert tail result reduce ['aEquals 'aNot 'aIf label] insert tail result translate/flat case-action insert tail result reduce ['aJump switchend 'end label] ] [ make-error! reform ["SWITCH case" mold case-value "does not return any value"] pos ] ) | any-type! ( make-error! "SWITCH has invalid cases" pos ) ] ] either default [ insert tail result translate/flat case ] [ remove/part skip tail result -4 2 ] insert tail result reduce ['end switchend] result ] trans-break: func [] [ copy either error? try [label: last break-labels] [ make-warning! "Nothing to break" pos [] ] [reduce ['aJump label]] ] trans-while: func [cond-block body-block /local result cond-translated startlabel endlabel] [ result: copy [] if empty? cond-block [ make-error! "Missing WHILE condition" pos return copy [] ] cond-translated: translate-value cond-block "WHILE condition" insert tail result reduce ['label startlabel: new-label] insert tail break-labels endlabel: new-label insert tail result cond-translated insert tail result reduce ['aNot 'aIf endlabel] insert tail result translate/flat body-block insert tail result reduce ['aJump startlabel 'end endlabel] remove back tail break-labels result ] trans-do-while: func [body-block cond-block /local result cond-translated startlabel endlabel] [ result: copy [] if empty? cond-block [ make-error! "Missing DO-WHILE condition" pos return result ] cond-translated: translate-value cond-block "DO-WHILE condition" insert tail break-labels endlabel: new-label insert tail result reduce ['label startlabel: new-label] insert tail result translate/flat body-block insert tail result cond-translated insert tail result reduce ['aIf startlabel] insert tail result reduce ['end endlabel] remove back tail break-labels result ] trans-for: func [word start end bump body /local result startlabel endlabel word-translated word-type start-translated set-word] [ result: copy [] if bump = 0 [ make-warning! "FOR 'bump' value must not be zero" pos return result ] word-translated: trans-GetWordOrPath word start-translated: translate-value start "FOR 'start'" end-translated: translate-value end "FOR 'end'" set-word: either 'aGetMember = last word-translated ['aSetMember] [ either 'aGetRegister = first word-translated [ reduce ['aSetRegister word-translated/2] ] ['aSetVariable] ] either block? set-word [ insert tail result start-translated insert tail result set-word insert tail result 'aPop insert tail break-labels endlabel: new-label insert tail result reduce ['label startlabel: new-label] insert tail result word-translated insert tail result end-translated insert tail result reduce [either bump > 0 ['aGreater] ['aLess] 'aNot 'aNot 'aIf endlabel] insert tail result translate/flat body insert tail result word-translated insert tail result reduce [bump 'aAdd2] insert tail result set-word insert tail result 'aPop insert tail result reduce ['aJump startlabel 'end endlabel] remove back tail break-labels ] [ insert tail result word-translated remove back tail result insert tail result start-translated insert tail result set-word insert tail break-labels endlabel: new-label insert tail result reduce ['label startlabel: new-label] insert tail result word-translated insert tail result end-translated insert tail result reduce [either bump > 0 ['aGreater] ['aLess] 'aNot 'aNot 'aIf endlabel] insert tail result translate/flat body insert tail result word-translated remove back tail result insert tail result word-translated insert tail result reduce [bump 'aAdd2 set-word] insert tail result reduce ['aJump startlabel 'end endlabel] remove back tail break-labels ] result ] trans-foreach: func [words data body /local result startlabel endlabel data-translated] [ comment "Should be optimized using register for data value" result: copy [] if not block? words [words: to block! words] data-translated: translate-value data "FOREACH 'data'" repend result [0 'label startlabel: new-label 'aPushDuplicate] insert tail result data-translated insert tail result ["length" aGetMember aGreaterEquals aIf] insert tail result endlabel: new-label while [not tail? words] [ either word? first words [ append result 'aPushDuplicate append result form first words append result 'aStackSwap insert tail result data-translated append result 'aStackSwap append result [aGetMember aSetVariable aIncrement] words: next words ] [ make-warning! reform ["Invalid datatype in FOREACH words (" mold first words ")"] pos remove words ] ] insert tail result translate/flat body insert tail result reduce ['aJump startlabel 'end endlabel 'aPop] result ] trans-with: func [object body /local result label object-translated] [ result: copy [] with-depth: with-depth + 1 object-translated: translate-value object "WITH object" defineLocals copy [] insert tail result object-translated insert tail result reduce ['aWith label: new-label] insert tail result translate/flat body insert tail result reduce ['end label] if 1 < l: length? localVars [ localVars/(l - 1): union localVars/(l - 1) copy last localVars ] with-depth: with-depth - 1 clearLocals result ] trans-tellTarget: func [object body /local result label object-translated] [ result: copy [] either swf-version < 4 [ insert tail result reduce ['aSetTarget to-string first object] defineLocals copy [] insert tail result translate/flat body insert tail result reduce ['aSetTarget ""] ] [ object-translated: translate-value object "TellTarget object" insert tail result object-translated insert tail result 'aSetTarget2 defineLocals copy [] insert tail result translate/flat body insert tail result reduce ['aSetTarget ""] ] if 1 < length? localVars [ localVars/(l - 1): union localVars/(l - 1) last localVars ] clearLocals result ] trans-rejoin: func [block /with divider [string!] /local result n p parts] [ result: copy [] n: 0 p: 0 foreach part parts: translate block [ switch last part [ aPop [remove back tail part] aSetVariable [change back tail part 'aStoreSetGetVariable] aSetMember [change back tail part 'aStoreSetGetMember] ] insert tail result part n: n + 1 p: p + 1 if all [with p < length? parts] [ insert tail result divider n: n + 1 ] ] insert/dup tail result 'aStringAdd (n - 1) result ] trans-func: func [spec body /local result params locals label paramsstr] [ result: copy [] params: copy [] paramsstr: copy "" parse spec [ any [ set p word! ( append params p append paramsstr join to-string p "^@" ) | /local copy locals to end | any-type! ] ] either none? locals [locals: copy []] [locals] insert tail result reduce ['aFunc "" length? params paramsstr label: new-label] if not empty? locals [ foreach var locals [insert tail result to-string var] insert/dup tail result 'aDefineLocal2 length? locals ] insert tail result translate/flat body insert tail result reduce ['end label] result ] trans-func2: func [spec body /local result params locals label translated] [ result: copy [] params: copy [] locals: copy [] parse spec [ any [ set p word! (append params to-string p) | /local any [ set p word! (append locals to-string p) | any-type! ] | any-type! ] ] insert locals params defineLocals locals translated: translate/flat body insert tail result reduce ['aFunc2 "" (length? params) copy last localVars] insert tail result label: new-label insert tail result translated insert tail result reduce ['endFunc2 label] clearLocals result ] trans-block: func [values /local result translated num] [ result: copy [] translated: head reverse translate/do-not-pop values num: length? translated insert tail result flat-block translated insert tail result reduce [num 'aInitArray] result ] trans-fscommand: func [args /local result mv1 mv2] [ result: copy [] parse args [ some [ [set mv1 [string! | 'exec | 'showmenu | 'fullscreen | 'allowscale | 'quit | 'trapallkeys | set-word!] (mv1: join "FSCommand:" to-string mv1) | set mv1 word! (mv1: reduce ["FSCommand:" form mv1 'aGetVariable 'aStringAdd]) ] [set mv2 [string! | 'true | 'false] (mv2: to-string mv2) | 'on (mv2: "true") | 'off (mv2: "false") | set mv2 word! (mv2: reduce [form mv2 'aGetVariable]) ] ( either all [string? mv1 string? mv2] [ insert tail result reduce ['aGetURL mv1 mv2] ] [ insert tail result mv1 insert tail result mv2 insert tail result 'aGetURL2 ] ) ] ] result ] trans-make-object: func [name args /local result argsTranslated transVal num vars val] [ result: copy [] if none? args [args: copy []] either name = 'object! [ num: 0 parse args [ any [ copy vars some set-word! copy val [to set-word! | to end] ( transVal: translate-value val "Make Object!" forall vars [ num: num + 1 insert tail result to-string vars/1 insert tail result transVal ] ) ] ] insert tail result reduce [num 'aDefineObject] ] [ either date? args [ argsTranslated: reduce [ args/day args/month - 1 args/year ] if not none? val: args/time [ insert argsTranslated reduce [ val/second - 1 val/minute - 1 val/hour - 1 ] ] ] [ argsTranslated: head reverse translate/do-not-pop/store args ] num: length? argsTranslated insert tail result flat-block argsTranslated insert tail result num if #"!" = last form name [ name: either none? val: select path-shortcuts name [ val: head remove back tail to-string name make-warning! reform ["Unknown path-shortcut" mold name "using:" mold val] pos val ] [val] ] insert tail result trans-GetWordOrPath name change back tail result either 'aGetVariable = last result ['aNewObject] ['aNewMethod] ] result ] trans-poke: func [value index data /local result] [ result: trans-GetWordOrPath value insert tail result translate-value index "POKE Index" insert tail result translate-value data "POKE Data" insert tail result 'aSetMember result ] trans-pick: func [series index /local result] [ result: trans-GetWordOrPath series insert tail result translate-value index "PICK Index" insert tail result 'aGetMember result ] trans-loadmovie: func [mv1 mv2 mv3 /local result] [ result: copy [] insert tail result translate-value index "POKE Index" either word? mv1 [do process-get-path mv1] [form-push mv1] either word? mv2 [do process-get-path mv2] [form-push mv2] form-act-tag #{9A} select [none #{40} post #{82} get #{81}] mv3 ] trans-class: func [classBlock extends /local className pre result name p val constructor trans label] [ pre: pop if 1 < length? pre [ make-error! "CLASS can have only one name!" pos ] if empty? pre [ make-error! "CLASS requires a name!" pos ] if not set-word? className: last pre [ make-error! "CLASS requires name (as a set-word!)" pos ] className: form className remove back tail pre constructor: none result: copy [] parse classBlock [any [ set name set-word! [copy val to set-word! | copy val to end] ( name: form name trans: translate val if 'aPop = last last trans [remove back tail last trans] either name = "init" [ constructor: last trans ] [ repend result ['aGetRegister "CLASSPROTO" name] append result last trans repend result 'aSetMember ] ) | p: any-type! ( make-error! "Invalid CLASS statement" p ) ]] either none? extends [ insert result reduce [ 'aGetRegister "CLASS1" "prototype" 'aGetMember 'aSetRegister "CLASSPROTO" 'aPop ] ] [ insert result reduce either swf-version < 7 [ [ "_global" 'aGetVariable className 'aGetMember "prototype" 0 form extends 'aNewObject 'aSetRegister "CLASSPROTO" 'aSetMember ] ] [ [ "_global" 'aGetVariable className 'aGetMember form extends 'aGetVariable 'aExtends 'aGetRegister "CLASS1" "prototype" 'aGetMember 'aSetRegister "CLASSPROTO" 'aPop ] ] ] insert result compose [ "_global" aGetVariable (className) ( either none? constructor [ compose [ aFunc "" 0 "" (label: new-label) 0 "super" aCallFunction aPop end (label) ] ] [constructor] ) aSetRegister "CLASS1" aSetMember ] append result compose [1 null "_global" aGetVariable (className) aGetMember "prototype" aGetMember 3 "ASSetPropFlags" aCallFunction ] push pre result ] RESERVED-WORDS: [ 'or | 'and | '= | '== | '!= | '!== | '** | '* | 'band | 'xor | '&& | '& | '|| | '. | slash | dslash | rShift | UrShift | _greater | _less | _noteql | _lesseql | _greatereql | lShift | 'func | 'while | 'do | 'if | 'else | 'foreach | 'for | 'switch | 'switch-default | 'make | 'new | 'fscommand | 'rejoin | 'reform | 'Modulo | 'InstanceOf | 'pick | 'poke | 'set | 'catch | 'throw | 'StopDrag | 'goto | 'gotoLabel | 'gotoFrame | 'stop ] ELEMENT: [ pos: (debug ["....element?" mold pos]) set mv1 [integer! | string! | issue! | binary! | decimal! | tuple! | file!] (push reduce [mv1] if string? mv1 [count-str mv1]) | 'rebol set mv1 block! set mv2 opt [block! | none] ( if none? mv2 [mv2: copy []] push translate-value reduce [(use mv2 mv1)] "REBOL include" ) | set mv1 block! (push trans-block mv1) | set mv1 date! (push trans-make-object 'Date mv1) | 'true (push copy [true]) | 'false (push copy [false]) | ['none | 'null] (push copy [#{02}]) | 'undefined (push copy [#{03}]) | 'newline (push copy ["^/"]) | 'GetTime (push copy [aGetTime]) | 'comment string! | 'StopDrag (push copy [aEndDrag]) | 'poke copy mv1 [word! | paren! | path!] copy mv2 any-type! copy mv3 any-type! (push trans-poke mv1 mv2 mv3) | 'pick copy mv1 any-type! copy mv2 any-type! (push trans-pick mv1 mv2) | set mv1 lit-word! ( push reduce [ either none? tmp: select local-constants to-word mv1 [ make-warning! reform ["Unknown local constant [" mold mv1 "]"] pos #{03} ] [tmp] ] ) | 'set 'color set mv1 word! opt ['to] set mv2 tuple! ( make-error! "set Color not supported anymore" pos ) | 'trace set mv1 paren! ( if trace? [push trans-callFunction 'cmsg to-paren reduce [to-paren compose/only [reform (to-block mv1)]]] ) | [ set mv1 RESERVED-WORDS ( make-error! reform ["Unrecognized/reserved word [" form mv1 "]"] pos ) | set mv1 [word! | path! | get-word!] set mv2 opt [paren! | none] ( either none? mv2 [ push trans-GetWordOrPath mv1 ] [push trans-callFunction mv1 mv2] ) ] | set mv1 paren! (push trans-paren mv1) | set mv1 any-type? ( make-error! reform ["Unrecognized datatype [" form mv1 "]"] pos ) ] SETWORD: [ (debug "....02 setword?") copy mv1 some ['var | set-word! | set-path!] (push mv1) LOGICAL_OR (trans-SetWordOrMember) | 'set set mv1 block! opt '= (push translate/do-not-pop mv1 "SET variable" mv1) LOGICAL_OR (trans-SetEvalWord) ] IFRULE: [ 'if copy mv1 to block! set mv2 block! opt ['else copy mv3 thru block!] ( push either none? mv3 [ trans-if mv1 mv2 ] [trans-either mv1 mv2 mv3] ) ] EITHERRULE: [ 'either copy mv1 to block! set mv2 block! set mv3 block! ( push trans-either mv1 mv2 mv3 ) ] UNARY: [ pos: (debug ["....03 unary?" mold pos]) '- UNARY (push head insert tail (insert pop [0]) 'aSubtract) | '+ UNARY | 'random UNARY (addUnaryAct 'aRandomNumber) | ['not | '!] UNARY (addUnaryAct 'aNot) | 'eval UNARY (addUnaryAct 'aGetVariable) | 'return UNARY (addUnaryAct 'aReturn) | 'delete UNARY ( mv1: pop switch/default last mv1 [ aGetVariable [change back tail mv1 'aDelete2] aGetMember [change back tail mv1 'aDelete] ] [insert tail mv1 'aDelete2] push head mv1 ) | 'typeOf UNARY (addUnaryAct 'aTypeOf) | 'to-integer UNARY (addUnaryAct 'aToInteger) | 'to-number UNARY (addUnaryAct 'aToNumber) | 'to-string UNARY (addUnaryAct 'aToString) | 'to-char UNARY (addUnaryAct 'aAsciiToChar) | 'to-mbchar UNARY (addUnaryAct 'aMBAsciiToChar) | 'to-ord UNARY (addUnaryAct 'aCharToAscii) | 'to-mbord UNARY (addUnaryAct 'aMBCharToAscii) | 'length? UNARY (addUnaryAct 'aStringLength) | 'mblength? UNARY (addUnaryAct 'aMBStringLength) | 'TargetPath UNARY (addUnaryAct 'aTargetPath) | ['make | 'new] set mv1 word! [set mv2 block! | set mv2 date! | copy mv2 opt [paren! | word! | string! | none]] ( push trans-make-object mv1 mv2 ) | 'break (push trans-break) | IFRULE | EITHERRULE | 'func set mv1 block! set mv2 block! ( push either any [noFunc2? swf-version < 7] [trans-func mv1 mv2] [trans-func2 mv1 mv2] ) | 'does set mv1 block! ( push either any [noFunc2? swf-version < 7] [trans-func copy [] mv1] [trans-func2 copy [] mv1] ) | 'class opt [(mv2: none) 'extends set mv2 word!] set mv1 block! (push trans-class mv1 mv2) | 'extends set mv2 word! set mv1 block! (push trans-class mv1 mv2) | ['switch | 'switch-default] copy mv1 to block! set mv2 block! set mv3 block! (push trans-switch/default mv1 mv2 mv3) | 'switch copy mv1 to block! set mv2 block! (push trans-switch mv1 mv2) | 'while set mv1 block! set mv2 block! (push trans-while mv1 mv2) | 'do set mv1 block! 'while set mv2 block! (push trans-do-while mv1 mv2) | 'for set mv1 word! copy mv2 [number! | word! | paren!] copy mv3 [number! | word! | paren!] set mv4 number! set mv5 block! (push trans-for mv1 mv2 mv3 mv4 mv5) | 'foreach set v [word! | block!] copy v2 to block! set v3 block! ( push trans-foreach v v2 v3 ) | 'with copy mv1 to block! set mv2 block! (push trans-with mv1 mv2) | 'tellTarget copy mv1 to block! set mv2 block! (push trans-tellTarget mv1 mv2) | 'rejoin set mv1 block! (push trans-rejoin mv1) | 'reform set mv1 block! (push trans-rejoin/with mv1 " ") | 'fscommand set mv1 block! (push trans-fscommand mv1) | 'LoadMovie set mv1 [string! | url! | file! | word!] opt ['to | 'into] set mv2 [string! | word! | path!] (mv3: 'none) opt [opt ['method] set mv3 ['post | 'get] ] ( make-warning! {loadMovie not supported anymore use target.loadMovie(url) instead} pos ) | 'GotoFrame set mv1 integer! (push reduce ['aGotoFrame mv1]) | 'GotoLabel set mv1 string! (push reduce ['aGotoLabel mv1]) | ['GotoFrame2 | 'goto opt ['frame]] set mv1 [integer! | word! | string!] opt ['and] set mv2 ['play | none] ( if word? mv1 [ mv1: either none? mv3: select rswf/names-ids-table mv1 [ make-warning! reform ["Unknown frame [" mold mv1 "]"] pos form mv1 ] [mv3] ] push reduce [mv1 'aGotoFrame2 either none? mv2 ['stop] ['play]] ) | set mv1 [ 'stop | 'play | 'nextFrame | 'prevFrame | 'previousFrame | 'toggleQuality | 'stopSounds ] set mv2 paren! ( push trans-callFunction mv1 mv2 ) | 'stop (push copy [aStop]) | 'play (push copy [aPlay]) | 'nextFrame (push copy [aNextFrame]) | ['previousFrame | 'prevFrame] (push copy [aPrevFrame]) | 'toggleQuality (push copy [aToggleQuality]) | 'stopSounds (push copy [aStopSounds]) | SETWORD | ELEMENT ] POW: [ pos: (debug ["....04 pow?" mold pos]) UNARY any [ '** POW ( addPostAct [2 "Math" aGetVariable "pow" aCallMember] ) ] ] MULTIPLICATIVE: [ pos: (debug ["....05 multiplicative?" mold pos]) 'Modulo POW POW (addPostAct 'aModulo) | POW any [ '* POW (addPostAct 'aMultiply) | slash POW (addPostAct 'aDivide) ] ] ADDITIVE: [ pos: (debug ["....06 aditive?" mold pos]) MULTIPLICATIVE any [ '+ MULTIPLICATIVE (addPostAct 'aAdd) | '- MULTIPLICATIVE (addPostAct 'aSubtract) | ['add | '.] MULTIPLICATIVE (addPostAct 'aStringAdd) ] ] BITWISE_SHIFT: [ (debug "....07 bshift?") ADDITIVE any [ rShift ADDITIVE (addPostAct 'aBitRShift) | lShift ADDITIVE (addPostAct 'aBitLShift) | UrShift ADDITIVE (addPostAct 'aBitURShift) ] ] RELATIONAL: [ (debug "....08 relational") BITWISE_SHIFT opt [ _less BITWISE_SHIFT (addPostAct 'aLess) | _greater BITWISE_SHIFT (addPostAct 'aGreater) | _lesseql BITWISE_SHIFT (addPostAct 'aLessEquals) | _greatereql BITWISE_SHIFT (addPostAct 'aGreaterEquals) | 'InstanceOf BITWISE_SHIFT (addPostAct 'aInstanceOf) ] ] EQUALITY: [ (debug "....09 equality?") RELATIONAL any [ ['= | '==] RELATIONAL (addPostAct 'aEquals) | ['!= | _noteql] RELATIONAL (addPostAct [aEquals aNot]) | '=== RELATIONAL (addPostAct 'aStrictEquals) | '!== RELATIONAL (addPostAct [aStrictEquals aNot]) ] ] BITWISE_AND: [EQUALITY any [['& | 'band] EQUALITY (addPostAct 'aBitAnd)]] BITWISE_XOR: [BITWISE_AND any ['xor BITWISE_AND (addPostAct 'aBitXor)]] BITWISE_OR: [BITWISE_XOR any ['| BITWISE_XOR (addPostAct 'aBitOr)]] LOGICAL_AND: [BITWISE_OR any [['&& | 'and] BITWISE_OR (addPostAct 'aAnd)]] LOGICAL_OR: [LOGICAL_AND any [['|| | 'or] LOGICAL_AND (addPostAct 'aOr)]] EXPRESSION: [ LOGICAL_OR ( finishExpression ) any [LOGICAL_OR ( finishExpression )] end | pos: ( make-error! "Invalid expression" pos ) ] parse code EXPRESSION head results ] translate-value: func [value errname /local value-translated] [ value-translated: translate/flat/store value either 'aPop = last value-translated [ head remove back tail value-translated ] [ make-error! reform [errname " has no value"] pos ] ] push-str-value: func [v /local p r] [ either none? p: find/case constantPool v [ if all [swf-version > 5 utf8-encode?] [v: utf8-encode v] rejoin [#{00} v #{00}] ] [ rejoin either (v: (-1 + index? p)) > 255 [ [#{09} int-to-ui8 v] ] [[#{08} int-to-ui8 v]] ] ] form-push-values: func [values /local v result] [ result: make binary! 200 parse values [some [ set v integer! (insert tail result either v = 0 [#{060000000000000000}] [join #{07} int-to-ui32 v]) | set v decimal! (insert tail result join #{06} to-ieee64/flash v) | set v string! (insert tail result push-str-value v) | set v string! (insert tail result push-str-value as-string v) | set v logic! (insert tail result join #{05} either v [#{01}] [#{00}]) | set v binary! (insert tail result v) | set v tuple! ( insert tail result either 2147483647 < v: tuple-to-decimal v [ join #{06} to-ieee64/flash v ] [ rejoin [#{07} int-to-ui32 v] ] ) | set v issue! ( insert tail result either 2147483647 < v: issue-to-decimal v [ join #{06} to-ieee64/flash v ] [ rejoin [#{07} int-to-ui32 v] ] ) | 'true (insert tail result #{0501}) | 'false (insert tail result #{0500}) | 'none (insert tail result #{0000}) | 'null (insert tail result #{02}) | 'aGetRegister set v string! ( if error? try [insert tail result join #{04} int-to-ui8 index? find last registers v] [ print ["!!!" mold v mold registers] halt ] ) | set v any-type! (insert tail result push-str-value to string! v) ]] result ] registers: copy [] set 'compile-actions func [ [catch] code /local mv1 tmp bytecode translated label pos err ] [ if empty? code [return copy #{}] labels: with-depth: 0 break-labels: copy [] clear registers bytecode: make binary! 10000 used-strings: make hash! 400 append-action-tag: func [id [binary!] data [binary! string!]] [ insert tail bytecode rejoin [id int-to-ui16 length? data data] ] translated: translate/flat code debug ["TRANSLATED:" mold translated] used-strings: sort/skip/compare/reverse to-block used-strings 2 2 branchesToSet: copy [] branchesLabels: make hash! 30 clear constantPool if all [ useConstantPool? swf-version > 4 not empty? used-strings used-strings/2 > 1 ] [ if 131070 < length? used-strings [ used-strings: copy/part used-strings 131070 ] use [cp] [ cp: make binary! 1000 foreach [string count] used-strings [ insert tail constantPool string insert tail cp join either all [swf-version > 5 utf8-encode?] [utf8-encode string] [string] #"^@" ] append-action-tag #{88} rejoin [int-to-ui16 (length? used-strings) / 2 cp] ] ] debug ["constantPool:" mold constantPool] parse translated [ any [ pos: 'aIf set mv1 word! ( insert tail bytecode #{9D02000000} repend branchesToSet [length? bytecode mv1] ) | ['end | 'label | 'endFunc2 (remove back tail registers)] set mv1 word! ( repend branchesLabels [mv1 length? bytecode] ) | 'aJump set mv1 word! ( insert tail bytecode #{9902000000} repend branchesToSet [length? bytecode mv1] ) | 'aWith set mv1 word! ( insert tail bytecode #{9402000000} repend branchesToSet [length? bytecode mv1] ) | 'aAdd (insert tail bytecode either swf-version > 4 [#{47}] [#{0A}]) | 'aLess (insert tail bytecode either swf-version > 4 [#{48}] [#{0F}]) | 'aEquals (insert tail bytecode either swf-version > 4 [#{49}] [#{0E}]) | 'aLessEquals ( insert tail bytecode either swf-version > 5 [#{6712}] [ either swf-version = 5 [#{4D4812}] [ make-error! {The LessOrEqual (<=) action is not supported for SWF4} pos ] ] ) | 'aSetRegister set mv1 string! ( if empty? registers [insert/only registers reduce [mv1]] if error? set/any 'err try [ insert tail bytecode rejoin [ #{870100} int-to-ui8 either none? tmp: find last registers mv1 [ insert tail last registers mv1 length? last registers ] [index? tmp] ] ] [ print ["!!!!!:" mold mv1 mold registers] probe disarm err ] ) | 'aGreaterEquals (insert tail bytecode either swf-version > 4 [#{4812}] [#{0F12}]) | 'aStoreSetGetVariable (insert tail bytecode #{870100001D9602000400}) | 'aSetGetVariable (insert tail bytecode #{1D9602000400}) | 'aStoreSetGetMember (insert tail bytecode #{870100004F9602000400}) | 'aSetGetMember (insert tail bytecode #{4F9602000400}) | 'aStoreSetGetProperty (insert tail bytecode #{87010000239602000400}) | 'aSetGetProperty (insert tail bytecode #{239602000400}) | 'aSetTarget set mv1 string! (append-action-tag #{8B} join mv1 #{00}) | 'aGotoFrame set mv1 integer! (insert tail bytecode rejoin [#{810200} int-to-ui16 mv1]) | 'aGoToLabel set mv1 string! (append-action-tag #{8C} join mv1 #{00}) | 'aGotoFrame2 set mv1 ['stop | 'play] (append-action-tag #{9F} either mv1 = 'stop [#{00}] [#{01}]) | 'aFunc set mv1 string! set mv2 integer! set mv3 string! set mv4 word! ( append-action-tag #{9B} rejoin [as-binary mv1 #{00} int-to-ui16 mv2 mv3 #{0000}] repend branchesToSet [length? bytecode mv4] ) | 'aFunc2 set mv1 string! set mv2 integer! set mv3 block! set mv4 word! ( use [flags f preload params n] [ preload: copy [] flags: 42 foreach var preloadVars [ if not none? f: find mv3 var [ remove f insert tail preload var switch var [ "this" [flags: (flags and 253) or 1] "arguments" [flags: (flags and 247) or 8] "super" [flags: (flags and 223) or 32] "_root" [flags: flags or 64] "_parent" [flags: flags or 128] "_global" [flags: flags or 256] ] ] ] n: length? preload params: make binary! 100 while [not tail? mv3] [ n: n + 1 if error? try [ insert tail params rejoin [int-to-ui8 n as-binary first mv3 #{00}] ] [ probe mv3 halt ] mv3: next mv3 ] probe mv2 probe mv3: head mv3 insert/only tail registers (head insert tail preload head mv3) append-action-tag #{8E} rejoin [ as-binary mv1 #{00} int-to-ui16 mv2 int-to-ui8 1 + n int-to-ui16 flags params #{0000} ] repend branchesToSet [length? bytecode mv4] ] ) | 'aGetURL set mv1 string! set mv2 string! ( append-action-tag #{83} rejoin [mv1 #"^@" mv2 #"^@"] ) | copy mv1 some [ string! | number! | tuple! | hash! | issue! | 'true | 'false | 'null | 'undefined | 'none | binary! | file! | 'aGetRegister string! ] ( either swf-version > 4 [ append-action-tag #{96} form-push-values mv1 ] [ forall mv1 [ append-action-tag #{96} form-push-values reduce [mv1/1] ] ] ) | set mv1 word! ( either none? tmp: select actionIds mv1 [ print ["!!Unknown action:" mv1 "^/!!near:" copy/part mold pos 100] ] [insert tail bytecode tmp] ) | any-type! ( make-error! "Compile error" pos ) ] ] foreach [pos label] branchesToSet [ change/part (at bytecode (pos - 1)) (int-to-ui16 ((select branchesLabels label) - pos)) 2 ] debug ["RESULT:" mold bytecode] bytecode ] set 'test func [code] [ probe x: compile-actions code rswf/parse-ActionRecord x ] ] comment "---- end of RS include %acompiler.r ----" comment { #### RS include: %swf-parser.r #### Title: "Swf-parser" #### Author: "David Oliva (commercial)" ----} comment { #### RS include: %stream-io.r #### Title: "stream-io" #### Author: "Oldes" ----} stream-io: context [ inBuffer: none bitCursor: 0 bitBuffer: none setStreamBuffer: func [buff] [ inBuffer: either port? buff [copy buff] [buff] bitCursor: 0 bitBuffer: none ] readBit: has [bit] [ if none? bitBuffer [ bitBuffer: first inBuffer bitCursor: 1 inBuffer: next inBuffer ] if (bit: 128 and bitBuffer) > 0 [bit: 1] either (bitCursor: bitCursor + 1) > 8 [ bitBuffer: none bitCursor: 0 ] [ bitBuffer: bitBuffer * 2 ] bit ] readBitLogic: has [bit] [ if none? bitBuffer [ bitBuffer: first inBuffer bitCursor: 1 inBuffer: next inBuffer ] bit: (128 and bitBuffer) > 0 either (bitCursor: bitCursor + 1) > 8 [ bitBuffer: none bitCursor: 0 ] [ bitBuffer: bitBuffer * 2 ] bit ] readSB: func [nbits [integer!] /local result] [ if nbits = 0 [return 0] result: copy "" loop nbits [append result readBit] insert/dup result result/1 (32 - nbits) to integer! debase/base result 2 ] readUB: func [nbits [integer!] /local result] [ if nbits = 0 [return 0] result: copy "" loop nbits [append result readBit] insert/dup result 0 (32 - nbits) to integer! debase/base result 2 ] readPair: has [nbits] [ nbits: readUB 5 reduce [readFB nbits readFB nbits] ] readSBPair: has [nbits] [ nbits: readUB 5 reduce [readSB nbits readSB nbits] ] readFB: func [nbits /local high low b] [ high: either nbits <= 17 [b: 0] [readSB (b: nbits - 17)] low: (readSB (nbits - b)) / 65535 high + low ] readRect: has [nbits result] [ byteAlign nbits: readUB 5 result: reduce [ readSB nbits readSB nbits readSB nbits readSB nbits ] byteAlign result ] byteAlign: does [ if bitCursor > 0 [ bitCursor: 0 bitBuffer: none ] inBuffer ] readByte: func [/local byte] [ byte: copy/part inBuffer 1 inBuffer: next inBuffer byte ] readBytes: func [nbytes /local bytes] [ bytes: copy/part inBuffer inBuffer: skip inBuffer nbytes bytes ] readBytesRev: func [nbytes] [ head reverse copy/part inBuffer inBuffer: skip inBuffer nbytes ] readBytesArray: func [ {Slices the binary data to parts which length is specified in the bytes block} bytes [block!] /local result b ] [ result: copy [] while [not tail? bytes] [ insert tail result readBytes bytes/1 bytes: next bytes ] result ] readRest: has [bytes] [ bytes: copy inBuffer inBuffer: tail inBuffer bytes ] readUI8: has [i] [i: first inBuffer inBuffer: next inBuffer i] readUI32: func [] [to integer! readBytesRev 4] readUI16: func [] [to integer! readBytesRev 2] readUI30: has [r b s] [ b: first inBuffer inBuffer: next inBuffer if b < 128 [return b] r: b and 127 s: 128 while [b: first inBuffer inBuffer: next inBuffer] [ r: r + (b * s) if 128 > b [return r] s: s + 128 ] ] readSI16: func [/local i] [ i: readBytesRev 2 i: either #{8000} = (i and #{8000}) [ negate (32768 - to integer! (i and #{7FFF})) ] [to integer! i] ] readSI8: func [/local i] [ i: readBytes 1 i: either #{80} = (i and #{80}) [ negate (128 - to integer! (i and #{7F})) ] [to integer! i] ] readShort: :readUI16 readLongFloat: func ["reads 4 bytes and converts them to decimal!" /local tmp] [ from-ieee32 join (readBytesRev 3) (readBytes 1) ] readULongFixed: has [l r] [ r: readUI16 l: readUI16 load ajoin [l #"." r] ] readSLongFixed: has [l r] [ r: readUI16 l: readSI16 load ajoin [l #"." r] ] readSShortFixed: has [l r] [ r: readUI8 l: readSI8 load ajoin [l #"." r] ] readRGB: does [to tuple! readBytes 3] readRGBA: does [to tuple! readBytes 4] readStringP: has [str] [ parse/all inBuffer [copy str to "^@" 1 skip inBuffer:] inBuffer: as-binary inBuffer str ] readStringNum: func [bytes] [ as-string readBytes bytes ] readString: does [ head remove back tail copy/part inBuffer inBuffer: find/tail inBuffer #{00} ] skipString: does [inBuffer: find/tail inBuffer #{00}] readUI30: has [r b s] [ b: first inBuffer inBuffer: next inBuffer if b < 128 [return b] r: b and 127 s: 128 while [b: first inBuffer inBuffer: next inBuffer] [ r: r + (b * s) if 128 > b [return r] s: s + 128 ] ] readCount: has [c] [ either 255 = c: readUI8 [readUI16] [c] ] readRGBAArray: func [count /local result] [ result: copy [] loop count [append result readRGBA] result ] readUI8Array: func [count /local result] [ result: copy [] loop count [append result readUI8] result ] readLongFloatArray: func [count /local result] [ result: copy [] loop count [append result readLongFloat] result ] isSetBit?: func [flags [integer!] bit [integer!] /local b] [ (b: to integer! (2 ** (bit - 1))) = (b and flags) ] skipRect: does [ byteAlign skipBits (4 * readUB 5) byteAlign ] skipPair: does [skipBits (2 * readUB 5)] skipBytes: func [nbytes] [inBuffer: skip inBuffer nbytes] skipByte: does [inBuffer: next inBuffer] skipUI16: does [inBuffer: skip inBuffer 2] skipUI32: does [inBuffer: skip inBuffer 4] skipRGB: does [inBuffer: skip inBuffer 3] skipRGBA: :skipUI32 skipSI16: :skipUI16 skipUI8: :skipByte skipBits: func [nbits] [ if bitCursor > 0 [ inBuffer: back inBuffer nbits: bitCursor + nbits - 1 ] inBuffer: skip inBuffer (to integer! (nbits / 8)) either 0 = bitCursor: nbits // 8 [ bitBuffer: none ] [ bitCursor: bitCursor + 1 bitBuffer: to integer! (2 ** (bitCursor - 1)) * first inBuffer inBuffer: next inBuffer ] none ] ] [ s: make stream-io [] s/setStreamBuffer #{F0CCAC} #{A9DEB36321} s/readUB 4 s/skipBits 4 s/skipBits 2 print s/readUB 2 s/skipBits 2 print s/readUB 2 s/skipBits 7 print s/readUB 1 ] [ s/skipBits 8 print [mold copy/part s/inBuffer 4 s/bitCursor s/bitBuffer] [ "1 1 1 1 0 0 0 0 1100 110010101100" ] ] comment "---- end of RS include %stream-io.r ----" comment { #### RS include: %ajoin.r #### Title: "Ajoin" #### Author: "David Oliva (commercial)" ----} if error? try [:ajoin] [ ajoin: func [ {Faster way how to create string from a block (in R3 it's native!)} block [block!] ] [to string! reduce block] ] comment "---- end of RS include %ajoin.r ----" swf-parser: make stream-io [ tagid: tagLength: tagData: none store?: false replaced-ids: make block! 200 imported-names: make block! 200 parse-swf-header: func [/local sig tmp] [ sig: readBytes 3 case [ sig = #{465753} [ swf/header/version: readUI8 readUI32 ] sig = #{435753} [ print ["This file is compressed Flash MX file!"] swf/header/version: readUI8 if error? set/any 'err try [inBuffer: as-binary decompress skip (join inBuffer (probe readBytes 4)) 4] [ clear tmp recycle print "Cannot decompress the data:(" probe disarm err halt ] print ["3:" stats] print length? inBuffer ] true [ print "Illegal swf header!" halt ] ] swf/header/frame-size: readRect byteAlign swf/header/frame-rate: to integer! readBytes 2 swf/header/frame-count: readUI16 ] open-swf-stream: func [swf-file [file! url! string!] "the SWF source file" /local f] [ if string? swf-file [swf-file: to-rebol-file swf-file] if none? swf-file [ swf-file: either empty? swf-file: ask "SWF file:" [%new.swf] [ either "http://" = copy/part swf-file 7 [to-url swf-file] [to-file swf-file] ] ] if not exists? swf-file [ f: join swf-file ".swf" either exists? f [swf-file: f] [print ["Cannot found the file" swf-file "!"]] ] swf: make object! [ file: swf-file header: make object! [version: frame-size: frame-rate: frame-count: none] data: copy [] ] read/binary swf-file ] foreach-swf-tag: func [action /local tagAndLength] [ bind action 'tagAndLength while [not tail? inBuffer] [ tagAndLength: readUI16 tagId: to integer! ((65472 and tagAndLength) / (2 ** 6)) tagLength: tagAndLength and 63 if tagLength = 63 [tagLength: readUI32] tagData: either tagLength > 0 [readBytes tagLength] [make binary! 0] do action ] ] set 'extract-swf-tags func [ "Returns block of specified SWF tags" swf-file [file! url! string!] "the SWF source file" tagids [block!] "Tag IDs to extract" /local result ] [ result: copy [] setStreamBuffer swf-stream: open-swf-stream swf-file if error? set/any 'err try [ parse-swf-header foreach-swf-tag [ if find tagids tagId [ repend result [tagId tagData] ] ] ] [ throw err ] result ] readSWFTags: func [swfTagsStream /local storeBuffer results onlyTagIds] [ storeBuffer: reduce [inBuffer bitCursor bitBuffer] setStreamBuffer swfTagsStream results: copy [] onlyTagIds: swf-tag-parser/onlyTagIds swf-tag-parser/spriteLevel: swf-tag-parser/spriteLevel + 1 foreach-swf-tag [ tagId if any [ none? onlyTagIds find onlyTagIds tagId ] [ insert/only tail results reduce [ tagId parse-swf-tag tagId tagData ] ] ] inBuffer: storeBuffer/1 bitCursor: storeBuffer/2 bitBuffer: storeBuffer/3 clear storeBuffer swf-tag-parser/spriteLevel: swf-tag-parser/spriteLevel - 1 results ] importSWFTags: func [swfTagsStream /local storeBuffer results importedResult] [ importedResult: make binary! 20000 storeBuffer: reduce [inBuffer bitCursor bitBuffer] setStreamBuffer swfTagsStream swf-tag-parser/spriteLevel: swf-tag-parser/spriteLevel + 1 while [not tail? inBuffer] [ tagStart: index? inBuffer tagAndLength: readUI16 tagId: to integer! ((65472 and tagAndLength) / (2 ** 6)) tagLength: tagAndLength and 63 if tagLength = 63 [tagLength: readUI32] tagData: either tagLength > 0 [readBytes tagLength] [make binary! 0] insert tail importedResult import-swf-tag tagId tagData ] inBuffer: storeBuffer/1 bitCursor: storeBuffer/2 bitBuffer: storeBuffer/3 clear storeBuffer swf-tag-parser/spriteLevel: swf-tag-parser/spriteLevel - 1 importedResult ] set 'exam-swf func [ "Examines SWF file structure" /file swf-file [file! url! string!] "the SWF source file" /quiet "No visible output" /into out-file [file!] /store {If you want to store parsed tags in the swf/data block} /only onlyTagIds [block!] /parseActions pActions [block! hash!] /local err sysprint sysprin action ] [ if all [file string? swf-file] [swf-file: to-rebol-file swf-file] store?: store setStreamBuffer open-swf-stream swf-file if error? set/any 'err try [ prin "Searching the binary file... " parse-swf-header print "-------------------------" probe swf/header print stats swf-tag-parser/verbal?: not quiet swf-tag-parser/output-file: either into [out-file: open/new/write out-file] [none] swf-tag-parser/parseActions: either parseActions [pActions] [swfTagParseActions] swf-tag-parser/onlyTagIds: onlyTagIds swf-tag-parser/swfVersion: swf/header/version foreach-swf-tag [ if any [ none? onlyTagIds find onlyTagIds tagId ] [ if store [repend/only swf/data [tagId tagData]] parse-swf-tag tagId tagData ] ] ] [ clear head inBuffer error? try [close swf-tag-parser/output-file] recycle throw err ] clear head inBuffer inBuffer: none recycle error? try [close out-file] swf ] set 'import-swf func [ {Reads SWF file, changes all IDs in the file not to conflict with given existing IDs and returns the new binary (without header)} swf-file [file! url! string!] "the SWF source file" used-tag-ids [block!] /except except-tag-ids [block!] /local importedSWF tagStart tagAndLength tagLength importedTags importedResult ] [ probe used-tag-ids clear replaced-ids clear imported-names importedTags: make block! 1000 importedResult: make binary! 20000 tagsStartIndex: 0 if all [string? swf-file] [swf-file: to-rebol-file swf-file] setStreamBuffer open-swf-stream swf-file if error? set/any 'err try [ parse-swf-header swf-tag-parser/parseActions: swfTagImportActions swf-tag-parser/swfVersion: swf/header/version swf-tag-parser/used-ids: used-tag-ids tagsStartIndex: index? inBuffer while [not tail? inBuffer] [ tagStart: index? inBuffer tagAndLength: readUI16 tagId: to integer! ((65472 and tagAndLength) / (2 ** 6)) tagLength: tagAndLength and 63 if tagLength = 63 [tagLength: readUI32] tagData: either tagLength > 0 [readBytes tagLength] [make binary! 0] insert tail importedResult import-swf-tag tagId tagData ] ] [ clear head inBuffer recycle throw err ] recycle reduce [ importedResult swf-tag-parser/last-depth imported-names swf-tag-parser/used-ids ] ] comment { #### Include: %parsers/swf-tags.r #### Title: "swfTags" #### Author: "" ----} swfTagNames: make hash! [0 "end" 1 "showFrame" 2 "DefineShape" 3 "FreeCharacter" 4 "PlaceObject" 5 "RemoveObject" 6 "DefineBits (JPEG)" 7 "DefineButton" 8 "JPEGTables" 9 "setBackgroundColor" 10 "DefineFont" 11 "DefineText" 12 "DoAction Tag" 13 "DefineFontInfo" 14 "DefineSound" 15 "StartSound" 18 "SoundStreamHead" 17 "DefineButtonSound" 19 "SoundStreamBlock" 20 "DefineBitsLossless" 21 "DefineBitsJPEG2" 22 "DefineShape2" 23 "DefineButtonCxform" 24 "Protect" 26 "PlaceObject2" 28 "RemoveObject2" 31 "?GeneratorCommand?" 32 "DefineShape3" 33 "DefineText2" 34 "DefineButton2" 35 "DefineBitsJPEG3" 36 "DefineBitsLossless2" 37 "DefineEditText" 38 "DefineVideo" 39 "DefineSprite" 40 "SWT-CharacterName" 41 "SerialNumber" 42 "DefineTextFormat" 43 "FrameLabel" 45 "SoundStreamHead2" 46 "DefineMorphShape" 48 "DefineFont2" 49 "?GenCommand?" 50 "?DefineCommandObj?" 51 "?Characterset?" 52 "?FontRef?" 56 "ExportAssets" 57 "ImportAssets" 58 "EnableDebugger" 59 "DoInitAction" 60 "DefineVideoStream" 61 "VideoFrame" 62 "DefineFontInfo2" 64 "ProtectDebug2" 65 "ScriptLimits" 66 "SetTabIndex" 67 "DefineShape4" 69 "FileAttributes" 70 "PlaceObject3" 71 "Import2" 73 "DefineAlignZones" 74 "CSMTextSettings" 75 "DefineFont3" 77 "MetaData" 78 "DefineScalingGrid" 72 "DoAction3" 76 "DoAction3StartupClass" 82 "DoAction3" 83 "DefineShape5" 84 "DefineMorphShape2" 86 "DefineSceneAndFrameLabelData" 87 "DefineBinaryData" 88 "DefineFontName" 1023 "DefineBitsPtr" ] swfTagParseActions: make hash! [ 2 [parse-DefineShape] 4 [parse-PlaceObject] 5 [parse-RemoveObject] 6 [parse-DefineBits] 7 [parse-DefineButton] 8 [parse-JPEGTables] 9 [to-tuple tagData] 10 [parse-DefineFont] 11 [parse-DefineText] 12 [parse-DoAction] 13 [parse-DefineFontInfo] 14 [parse-DefineSound] 15 [parse-StartSound] 17 [parse-DefineButtonSound] 18 [parse-SoundStreamHead] 19 [parse-SoundStreamBlock] 20 [parse-DefineBitsLossless] 21 [parse-DefineBitsJPEG2] 22 [parse-DefineShape] 23 [parse-DefineButtonCxform] 26 [parse-PlaceObject2] 28 [parse-RemoveObject2] 32 [parse-DefineShape] 33 [parse-DefineText] 34 [parse-DefineButton2] 35 [parse-DefineBitsJPEG3] 36 [parse-DefineBitsLossless] 37 [parse-DefineEditText] 39 [parse-DefineSprite] 40 [parse-SWT-CharacterName] 41 [parse-SerialNumber] 42 [parse-DefineTextFormat] 43 [readSTRING] 45 [parse-SoundStreamHead] 46 [parse-DefineMorphShape] 48 [parse-DefineFont2] 56 [parse-ExportAssets] 57 [parse-ImportAssets] 58 [parse-EnableDebugger] 59 [parse-DoInitAction] 60 [parse-DefineVideoStream] 61 [parse-VideoFrame] 62 [parse-DefineFontInfo2] 64 [parse-EnableDebugger2] 65 [parse-ScriptLimits] 66 [parse-SetTabIndex] 67 [parse-DefineShape] 69 [parse-FileAttributes] 70 [parse-PlaceObject3] 71 [parse-ImportAssets2] 73 [parse-DefineAlignZones] 74 [parse-CSMTextSettings] 75 [parse-DefineFont2] 77 [as-string tagData] 78 [parse-DefineScalingGrid] 72 [parse-DoABC] 76 [parse-SymbolClass] 82 [parse-DoABC2] 83 [parse-DefineShape] 84 [parse-DefineMorphShape2] 86 [parse-DefineSceneAndFrameLabelData] 87 [parse-DefineBinaryData] 88 [parse-DefineFontName] ] swfTagImportActions: make hash! [ 2 [import-Shape] 4 [replacedID] 5 [replacedID] 6 [changeID] 7 [import-DefineButton] 10 [changeID] 11 [import-DefineText] 13 [replacedID] 14 [changeID] 15 [replacedID] 17 [import-DefineButtonSound] 20 [changeID] 21 [changeID] 22 [import-Shape] 23 [replacedID] 26 [import-PlaceObject2] 32 [import-Shape] 33 [import-DefineText] 34 [import-DefineButton2] 35 [changeID] 36 [changeID] 37 [import-DefineEditText] 38 [changeID] 39 [import-DefineSprite] 40 [changeID] 42 [print "!! Importing unknown TAG DefineTextFormat" replacedID] 46 [import-DefineMorphShape] 48 [changeID] 56 [import-ExportAssets] 57 [import-ImportAssets] 59 [replacedID] 60 [changeID] 61 [replacedID] 62 [replacedID] 67 [import-Shape] 70 [import-PlaceObject2] 71 [import-ImportAssets] 73 [replacedID] 74 [replacedID] 75 [changeID] 78 [replacedID] 76 [import-SymbolClass] 83 [import-Shape] 84 [import-DefineMorphShape2] 87 [changeID] 88 [replacedID] ] comment "---- end of include %parsers/swf-tags.r ----" comment { #### Include: %swf-tag-parser.r #### Title: "swf-tag-parser" #### Author: "" ----} swf-tag-parser: make stream-io [ verbal?: on output-file: none parseActions: copy [] tagSpecifications: copy [] onlyTagIds: none swfVersion: none used-ids: none last-depth: none set 'parse-swf-tag func [tagId tagData /local err action st st2] [ either none? action: select parseActions tagId [ result: none ] [ setStreamBuffer tagData if error? set/any 'err try [ set/any 'result do bind/copy action 'self ] [ print ajoin ["!!! ERROR while parsing tag:" select swfTagNames tagId "(" tagId ")"] throw err ] ] if spriteLevel = 0 [ if verbal? [ prin getTagInfo tagId result ] if port? output-file [ insert tail output-file getTagInfo tagId result ] ] result ] readID: :readUI16 readUsedID: :readUI16 spriteLevel: 0 StreamSoundCompression: none comment { ^-StreamSoundCompression - ^-^-defined in SoundStreamHead tag ^-^-used in SoundStreamBlock ^-} tabs: copy "" tabsspr: copy "" tabind+: does [append tabs "^-"] tabind-: does [remove tabs] tabspr+: does [append tabsspr "^-"] tabspr-: does [remove tabsspr] getTagInfo: func [tagId data /local fields] [ ajoin [ tabsspr select swfTagNames tagId "(" either tagId < 10 [join "0" tagId] [tagId] "):" either none? fields: select tagFields tagId [ join either none? data ["x"] [join " " mold data] LF ] [ join LF getTagFields data :fields true ] ] ] getTagFields: func [data fields indent? /local result fld res p name ind l] [ if none? data [return ""] if indent? [tabind+] result: copy "" if not block? data [data: reduce [data]] either function? :fields [ insert tail result fields data ] [ parse fields [any [ p: (if any [not block? data tail? data] [p: tail p]) :p [ set fld string! ( res: either none? data/1 [""] [ ajoin [ tabs fld ": " either all [ binary? data/1 20 < l: length? data/1 ] [ ajoin [l " Bytes = " head remove back tail mold copy/part data/1 10 "..."] ] [mold data/1] LF ] ] ) | set fld block! set ind ['noIndent | none] ( res: getTagFields data/1 fld (ind <> 'noIndent) ) | set fld function! (res: fld data/1) | 'group set name string! set fld block! set ind ['noIndent | none] ( res: either none? data/1 [""] [ ajoin [tabs name ": [^/" getTagFields data/1 fld (ind <> 'noIndent) tabs "]^/"] ] ) | 'get set name [lit-word! | word!] set ind ['noIndent | none] ( if ind = 'noIndent [tabind-] res: ajoin [tabs name ": " getFieldData name data/1 LF] if ind = 'noIndent [tabind+] ) ] ( insert tail result res data: next data ) ]] data: head data fields: head fields ] if indent? [tabind-] result ] comment { #### Include: %parsers/swf-tags-fields.r #### Title: "swfTags - Fields" #### Author: "" ----} pad: func [val num] [head insert/dup tail val: form val #" " num - length? val] formatFillStyle: func [data /local] [ ajoin switch/default data/1 [0 [["color: " data/2 LF]] 16 [[ "linearGradiend:" LF getTagFields data/2/1 fieldsMATRIX true getFieldData 'Gradients data/2/2 ]] 18 [[ "radialGradient:" LF getTagFields fieldsMATRIX data/2/1 true getFieldData 'Gradients data/2/2 ]] 19 [[ "focalGradient:" LF getTagFields fieldsMATRIX data/2/1 true getFieldData 'Gradients data/2/2 ]] 64 [[ "repeating bitmap ID: " data/2/1 LF getTagFields data/2/2 fieldsMATRIX true ]] 65 [[ "clipped bitmap ID:" data/2/1 LF getTagFields data/2/2 fieldsMATRIX true ]] 66 [[ "non-smoothed repeating bitmap ID:" data/2/1 LF getTagFields data/2/2 fieldsMATRIX true ]] 67 [[ "non-smoothed clipped bitmap ID:" data/2/1 LF getTagFields data/2/2 fieldsMATRIX true ]] ] [[data LF]] ] getFieldData: func [type data /local i row result val] [ result: copy "" if none? data [return result] tabind+ switch type [ FillStyles [ append result LF i: 1 while [not tail? data] [ row: data/1 append result ajoin [ tabs "#" i " " formatFillStyle row ] i: i + 1 comment { ^-^-^-^-type >= 64 [ ;bitmap ^-^-^-^-^-reduce [ ^-^-^-^-^-^-readID ;bitmapID ^-^-^-^-^-^-readMATRIX ^-^-^-^-^-] ^-^-^-^-] ^-^-^-]" ^-^-^-^-^-mold data/1 LF ^-^-^-^-] ^-^-^-^-} data: next data ] ] LineStyles [ i: 1 while [not tail? data] [ row: data/1 append result ajoin [ LF tabs "#" i ": " "width: " row/1 either none? row/2 [""] [" miterLimit:" row/2] ajoin either tuple? row/3 [ [" color: " row/3] ] [[" " formatFillStyle row/3]] ] data: next data i: i + 1 ] ] Gradients [ append result ajoin [tabs "GradientColors: " LF] while [not tail? data] [ append result ajoin [tabs "^-" pad data/1 5 data/2 LF] data: skip data 2 ] ] ShapeRecords [ append result ajoin [LF tabs "Style:" LF] parse data [any [ 'style set val block! ( append result ajoin [tabs "ChangeStyle: " LF getTagFields val fieldsStyleChangeRecord true] ) | 'line copy val some [integer!] ( append result ajoin [tabs "Line: " val LF] ) | 'curve copy val some [integer!] ( append result ajoin [tabs "Curve: " val LF] ) ]] ] SpriteTags [ append result LF tabspr+ while [not tail? data] [ append result getTagInfo data/1/1 data/1/2 data: next data ] tabspr- ] SoundStreamBlock [ if data/1 = 2 [ append result ajoin [ "MP3" LF getTagFields next data [ "SampleCount" group "MP3SOUNDDATA" [ "SeekSamples" get 'MP3FRAMEs ] ] true ] ] ] MP3FRAMEs [ foreach [ Syncword MpegVersion Layer ProtectionBit ChannelMode ModeExtension Copyright Original Emphasis Bitrate SamplingRate soundata ] data [ append result ajoin [ LF tabs "MpegVersion: " pick [2.5 "" 2 1] (1 + MpegVersion) " Layer: " pick ["" "III" "II" "I"] (1 + Layer) " CRC: " ProtectionBit = 1 LF tabs "Bitrate: " Bitrate " SamplingRate: " SamplingRate " PaddingBit: " PaddingBit = 1 LF tabs "ChannelMode: " pick ["Stereo" "Joint stereo (Stereo)" "Dual channel" "Single channel (Mono)"] (1 + ChannelMode) " Copyright: " Copyright = 1 " Original: " Original = 1 " Emphasis: " pick [none "50/15 ms" "" "CCIT J.17"] (1 + Emphasis) LF tabs "SampleDataSize: " length? soundata ] ] ] BUTTONRECORDs [ append result LF while [not tail? data] [ append result getTagFields data/1 fieldsBUTTONRECORDs true data: next data ] ] BUTTONstates [ append result ajoin [ data " =" either isSetBit? data 1 [" up"] [""] either isSetBit? data 2 [" over"] [""] either isSetBit? data 3 [" down"] [""] either isSetBit? data 4 [" hit"] [""] LF ] ] ] error? try [data: head data] tabind- trim/tail result ] fieldsFillStyles: func [data] [ tabind+ result: copy "" ] fieldsDefineShape: [ "ID" "Bounds" group "Edge" [ "EdgeBounds" "UsesNonScalingStrokes" "UsesScalingStrokes" ] group "StylesAndShapes" [ get 'FillStyles get 'LineStyles get 'ShapeRecords ] ] fieldsMATRIX: [ "Scale" "Rotate" "Translate" ] fieldsCXFORM: [ "Multiplication" "Addition" ] fieldsBUTTONRECORDs: reduce [ 'get 'BUTTONstates 'noIndent "ID" "PlaceDepth" fieldsMATRIX 'noIndent fieldsCXFORM 'noIndent ] fieldsStyleChangeRecord: [ "Move" "FillStyle0" "FillStyle1" "LineStyle" group "NewStyles" [ get 'FillStyles get 'LineStyles "numFillBits" "numLineBits" ] ] fieldsDefineText: reduce [ "ID" "TextBounds" fieldsMATRIX 'noIndent 'group "TextRecords" [ "FontID" "Color" "XOffset" "YOffset" "TextHeight" "Glyphs" ] ] fieldsDefineBitsLossless: [ "BitmapID" "BitmapFormat" "BitmapWidth" "BitmapHeight" "BitmapColorTableSize" "ZlibBitmapData" ] fieldsSoundStreamHead: [ "reserved" "PlaybackSoundRate" "16bit?" "Stereo?" "StreamSoundCompression" "StreamSoundRate" "StreamSoundSize" "StreamSoundType" "StreamSoundSampleCount" "LatencySeek" ] fieldsSOUNDINFO: [ "reserved" "SyncStop?" "SyncNoMultiple?" "InPoint" "OutPoint" "Loops" "Envelope" ] fieldsStartSound: reduce [ "SoundID" fieldsSOUNDINFO 'noIndent ] comment { #### Include: %format/actions.r #### Title: "SWF Actions formater" #### Author: "" ----} actionFormater: context [ cp: ["^H" copy v 1 skip (append vals rejoin ["CP:" pick ConstantPool v: 1 + str-to-int v]) ] i32: ["^G" copy v 4 skip (append vals v: str-to-int v) ] pstr: ["^@" copy v to "^@" 1 skip (append vals v) ] logic: ["^E" copy v 1 skip (append vals pick [false true] 1 + str-to-int v) ] null: ["^B" (append vals 'null)] undefined: ["^C" (append vals 'undefined)] dec: ["^F" copy v 8 skip (append vals from-ieee64/flash as-binary v) ] reg: ["^D" copy v 1 skip (append vals to-path join "register/" str-to-int v) ] str: [copy v to "^@" 1 skip (append vals v)] word: [copy v 2 skip (append vals str-to-int v)] ConstantPool: copy [] fieldsACTIONRECORDs: func [actionRecords /local result val] [ result: copy [] while [not tail? actionRecords] [ aTagId: actionRecords/1 aTagData: actionRecords/1 append result ajoin [ tabs mold aTagId #" " either none? aTagName: select actionids aTagId [ "UnknownTag" ] [tagName] either empty? aTagData [""] [ mold switch/default aTagName [ "aGetURL" [parse/all data "^@"] "aConstantPool" [ clear ConstantPool parse/all data [ 2 skip any [copy val to "^@" 1 skip (insert tail ConstantPool val)] ] ConstantPool ] "aIf" [ ofs: sb-to-int data either ofs < 0 [ print [tabs aname data "(" ofs ")"] ] [ print [tabs aname] parse-ActionRecord bin-part ofs ] ] "aDefineFunction" [ vals: make block! [] set [data codeSize] slice-bin data reduce [(length? data) - 2 2] parse/all data [str word any [str]] print [tabs aname rejoin [vals/1 mold skip vals 2] mold codeSize] parse-ActionRecord bin-part bin-to-int codeSize ] "aDefineFunction2" [ vals: make block! [] use [name tmp NumParams RegisterCount flags params unknown reg par Suppress] [ parse/all data [copy name to #"^@" 1 skip data: to end] data: as-binary data print [tabs aname actionid name] set [NumParams RegisterCount flags] slice-bin data reduce [2 1 2] data: skip data 5 NumParams: to-integer head reverse NumParams RegisterCount: to-integer RegisterCount flags: enbase/base as-binary flags 2 params: make block! 20 Suppress: make block! 3 if #"1" = flags/1 [ insert params [0 "_parent"] ] if #"1" = flags/2 [ insert params [0 "_root"] ] if #"1" = flags/3 [ append Suppress "super" ] if #"1" = flags/4 [ insert params [0 "super"] ] if #"1" = flags/5 [ append Suppress "arguments" ] if #"1" = flags/6 [ insert params [0 "arguments"] ] if #"1" = flags/7 [ append Suppress "this" ] if #"1" = flags/8 [ insert params [0 "this"] ] if #"1" = flags/16 [ insert params [0 "_global"] ] loop NumParams [ parse/all data [ copy reg 1 skip copy par to "^@" 1 skip (repend params [to-integer as-binary reg to-string par]) data: to end ] ] codeSize: bin-to-int copy/part data 2 print [tabs "|_ NumParams:" NumParams "RegisterCount:" RegisterCount "Flags:" flags "codeSize:" codeSize] print [tabs "\_ PARAMS:" mold params "Suppress:" mold Suppress] ] parse-ActionRecord bin-part codeSize ] "aPush" [ vals: make block! [] parse/all data [some [cp | i32 | dec | pstr | logic | reg | null | undefined]] print [tabs aname mold vals] ] ] [ ] ] LF ] data: skip data 2 ] result ] actionids: make hash! [ #{00} "END of aRecord" #{04} "aNextFrame" #{05} "aPrevFrame" #{06} "aPlay" #{07} "aStop" #{08} "aToggleQuality" #{09} "aStopSounds" #{81} "aGotoFrame" #{83} "aGetURL" #{8A} "aWaitForFrame" #{8B} "aSetTarget" #{8C} "aGoToLabel" #{96} "aPush" #{17} "aPop" #{0A} "aAdd" #{0B} "aSubtract" #{0C} "aMultiply" #{0D} "aDivide" #{0E} "aEquals" #{0F} "aLess" #{10} "aAnd" #{11} "aOr" #{12} "aNot" #{13} "aStringEquals" #{14} "aStringLength" #{21} "aStringAdd" #{15} "aStringExtract" #{29} "aStringLess" #{31} "aMBStringLength" #{35} "aMBStringExtract" #{18} "aToInteger" #{32} "aCharToAscii" #{33} "aAsciiToChar" #{36} "aMBCharToAscii" #{37} "aMBAsciiToChar" #{99} "aJump" #{9D} "aIf" #{9E} "aCall" #{1C} "aGetVariable" #{1D} "aSetVariable" #{9A} "aGetURL2" #{9F} "aGotoFrame2" #{20} "aSetTarget2" #{22} "aGetProperty" #{23} "aSetProperty" #{24} "aCloneSprite" #{25} "aRemoveSprite" #{27} "aStartDrag" #{28} "aEndDrag" #{8D} "aWaitForFrame2" #{26} "aTrace" #{34} "aGetTime" #{30} "aRandomNumber" #{3D} "aCallFunction" #{52} "aCallMethod" #{88} "aConstantPool" #{9B} "aDefineFunction" #{3C} "aDefineLocal" #{41} "aDefineLocal2" #{43} "aDefineObject" #{3A} "aDelete" #{3B} "aDelete2" #{46} "aEnumerate" #{49} "aEquals2" #{4E} "aGetMember" #{42} "aInitArray/Object" #{53} "aNewMethod" #{40} "aNewObject" #{4F} "aSetMember" #{45} "aTargetPath" #{94} "aWith" #{4A} "aToNumber" #{4B} "aToString" #{44} "aTypeOf" #{47} "aAdd2" #{48} "aLess2" #{3F} "aModulo" #{60} "aBitAnd" #{63} "aBitLShift" #{61} "aBitOr" #{64} "aBitRShift" #{65} "aBitURShift" #{62} "aBitXor" #{51} "aDecrement" #{50} "aIncrement" #{4C} "aPushDuplicate" #{3E} "aReturn" #{4D} "aStackSwap" #{87} "aStoreRegister" #{54} "aInstanceOf" #{55} "aEnumerate2" #{66} "aStrictEqual" #{67} "aGreater" #{68} "aStringGreater" #{69} "aExtends" #{2A} "aThrow" #{2B} "aCastOp" #{2C} "aImplementsOp" #{8E} "aDefineFunction2" #{8F} "aTry" ] ] comment "---- end of include %format/actions.r ----" fieldsACTIONRECORDs: none tagFields: make hash! reduce [ 2 fieldsDefineShape 4 reduce [ "ID" "Depth" fieldsMATRIX fieldsCXFORM ] 5 ["ID" "Depth"] 6 ["ID" "JPEGData"] 7 reduce [ "ID" 'get 'BUTTONRECORDs :fieldsACTIONRECORDs ] 8 ["JPEGData"] 10 ["ID" "GlyphShapeTable"] 11 fieldsDefineText 12 :fieldsACTIONRECORDs 13 [ "FontID" "Name" "Flags" "CodeTable" ] 14 [ "ID" "Format" "Rate" "Size" "Type" "SampleCount" "Data" ] 15 reduce [ "ID" 'group fieldsSOUNDINFO ] 17 reduce [ "ButtonID" 'group "OverUpToIdle" fieldsStartSound 'group "IdleToOverUp" fieldsStartSound 'group "OverUpToOverDown" fieldsStartSound 'group "OverDownToOverUp" fieldsStartSound ] 18 fieldsSoundStreamHead 19 [ get 'SoundStreamBlock ] 20 fieldsDefineBitsLossless 21 ["ID" "JPEGData"] 22 fieldsDefineShape 23 [ "ButtonID" fieldsCXFORM ] 26 reduce [ "Depth" "Move?" "Character" fieldsMATRIX fieldsCXFORM "Ratio" "Name" "ClipDepth" 'group "CLIPACTIONS" [ "reserved" "AllEventFlags" "Actions" ] ] 28 ["Depth"] 32 fieldsDefineShape 33 fieldsDefineText 34 reduce [ "ID" 'get 'BUTTONRECORDs :fieldsACTIONRECORDs ] 35 ["ID" "JPEGData" "BitmapAlphaData"] 36 fieldsDefineBitsLossless 37 [ "ID" "Bounds" "WordWrap?" "Multiline?" "Password?" "ReadOnly?" "Reserved1" "AutoSize?" "NoSelect?" "Border?" "Reserved2" "HTML?" "UseOutlines?" group "Font" ["FontID" "Height"] "TextColor" "MaxLength" group "Layout" [ "Align" "LeftMargin" "RightMargin" "Indent" "Leading" ] "VariableName" "InitialText" ] 39 [ "ID" "Depth" get 'SpriteTags ] 43 [readSTRING] 45 fieldsSoundStreamHead 46 [] 48 [ "ID" "Flags" "LangCode" "FontName" "GlyphShapeTable" "CodeTable" group "Layout" [ "FontAscent" "FontDescent" "FontLeading" "FontAdvanceTable" "FontBoundsTable" "KERNINGRECORDs" ] ] 57 [ "FromURL" "Assets" ] 59 reduce [ "CharacterID" :fieldsACTIONRECORDs ] 60 [] 61 [] 62 [] 64 [] 65 [] 66 [] 67 fieldsDefineShape 69 [] 70 reduce [ "Depth" "Move?" "Character" fieldsMATRIX fieldsCXFORM "Ratio" "Name" "ClipDepth" "Filters" "Blend" "BitmapCaching" 'group "CLIPACTIONS" [ "reserved" "AllEventFlags" "Actions" ] ] 73 [] 74 [] 75 [] 77 [as-string tagData] 78 [ "CharID" "GridRectangle" ] 72 [] 76 [] 82 [] 83 fieldsDefineShape 84 [] 86 [] 87 [] 88 [] ] comment {---- end of include %parsers/swf-tags-fields.r ----} comment { #### Include: %parsers/basic-datatypes.r #### Title: "SWF basic datatypes parse functions" #### Author: "" ----} readMATRIX: does [ byteAlign reduce [ either readBitLogic [readPair] [none] either readBitLogic [readPair] [none] readSBPair ] ] readCXFORM: has [HasAddTerms? HasMultTerms? nbits] [ HasAddTerms?: readBitLogic HasMultTerms?: readBitLogic nbits: readUB 4 reduce [ either HasMultTerms? [ reduce [ readSB nbits readSB nbits readSB nbits ] ] [none] either HasAddTerms? [ reduce [ readSB nbits readSB nbits readSB nbits ] ] [none] ] ] readCXFORMa: has [HasAddTerms? HasMultTerms? nbits] [ HasAddTerms?: readBitLogic HasMultTerms?: readBitLogic nbits: readUB 4 reduce [ either HasMultTerms? [ reduce [ readSB nbits readSB nbits readSB nbits readSB nbits ] ] [none] either HasAddTerms? [ reduce [ readSB nbits readSB nbits readSB nbits readSB nbits ] ] [none] ] ] comment {---- end of include %parsers/basic-datatypes.r ----} comment { #### Include: %parsers/font-and-text.r #### Title: "SWF font and text parse functions" #### Author: "" ----} parse-DefineFont: has [id OffsetTable GlyphShapeTable last-ofs] [ reduce [ readID ( OffsetTable: make block! ofs / 2 loop (ofs / 2) - 1 [ append OffsetTable (readUI16) - ofs ] append OffsetTable length? inBuffer GlyphShapeTable: make block! (ofs / 2) last-ofs: 0 foreach ofs OffsetTable [ append GlyphShapeTable readBytes (ofs - last-ofs) last-ofs: ofs ] GlyphShapeTable ) ] ] parse-DefineFont2: has [ flags OffsetTable NumGlyphs WideOffsets? CodeTableOffset GlyphShapeTable last-ofs ] [ reduce [ readID flags: readUI8 readUI8 as-string readBytes readUI8 ( NumGlyphs: readUI16 WideOffsets?: 8 = (8 and flags) loop NumGlyphs [ either WideOffsets? [readUI32] [readUI16] ] either WideOffsets? [readUI32] [readUI16] GlyphShapeTable: copy [] loop NumGlyphs [ byteAlign append/only GlyphShapeTable readSHAPE ] GlyphShapeTable ) readStringNum (NumGlyphs * either WideOffsets? [4] [2]) either 128 = (128 and flags) [ reduce [ readSI16 readSI16 readSI16 ( tmp: copy [] loop NumGlyphs [append tmp readSI16] tmp ) ( clear tmp loop NumGlyphs [append tmp readRECT] tmp ) ( byteAlign readKERNINGRECORDs WideOffsets? ) ] ] [none] ] ] parse-DefineText: does [ reduce [ readID readRECT readMATRIX readTEXTRECORD (byteAlign readUI8) readUI8 ] ] parse-DefineEditText: has [HasText? HasTextColor? HasMaxLength? HasFont? HasLayout?] [ reduce [ readID readRECT ( byteAlign HasText?: readBitLogic readBitLogic ) readBitLogic readBitLogic readBitLogic ( HasTextColor?: readBitLogic HasMaxLength?: readBitLogic HasFont?: readBitLogic readBit ) readBitLogic ( HasLayout?: readBitLogic readBitLogic ) readBitLogic readBit readBitLogic readBitLogic either HasFont? [reduce [readUsedID readUI16]] [none] either HasTextColor? [readRGBA] [none] either HasMaxLength? [readUI16] [none] either HasLayout? [ reduce [ readUI8 readUI16 readUI16 readUI16 readUI16 ] ] [none] readString either HasText? [readString] [none] ] ] parse-DefineTextFormat: does [ readRest ] readTEXTRECORD: func [GlyphBits AdvanceBits /local records HasFont? HasColor? HasYOffset? HasXOffset?] [ records: copy [] while [readBitLogic] [ readUB 3 HasFont?: readBitLogic HasColor?: readBitLogic HasYOffset?: readBitLogic HasXOffset?: readBitLogic append records reduce [ either HasFont? [readUsedID] [none] either HasColor? [either tagId = 11 [readRGB] [readRGBA]] [none] either HasXOffset? [readSI16] [none] either HasYOffset? [readSI16] [none] either HasFont? [readUI16] [none] readGLYPHENTRY GlyphBits AdvanceBits ] ] byteAlign records ] readGLYPHENTRY: func [GlyphBits AdvanceBits /local glyphs] [ glyphs: copy [] loop readUI8 [ insert tail glyphs reduce [ readUB GlyphBits readSB AdvanceBits ] ] glyphs ] readKERNINGRECORDs: func [wide? /local result] [ result: copy [] either wide? [ loop readUI16 [ insert tail result reduce [ readUI16 readUI16 readSI16 ] ] ] [ loop readUI16 [ insert tail result reduce [ readUI8 readUI8 readSI16 ] ] ] result ] parse-DefineFontInfo: has [flags] [ reduce [ readUsedID as-string readBytes readUI8 readUI8 readRest ] ] parse-DefineFontInfo2: has [flags] [ reduce [ readUsedID as-string readBytes readUI8 readUI8 readUI8 readRest ] ] parse-DefineAlignZones: does [reduce [ readUsedID readUB 2 readALIGNZONERECORDs ]] readALIGNZONERECORDs: has [records numZoneData zoneData] [ records: copy [] while [not tail? inBuffer] [ repend/only records [ ( numZoneData: readUI8 zoneData: make block! numZoneData loop numZoneData [ insert tail zoneData readUI32 ] zoneData ) readUI8 ] ] records ] parse-CSMTextSettings: does [reduce [ readUsedID readUB 2 readUB 3 readUB 3 readUI32 readUI32 readUI8 ]] parse-DefineFontName: does [reduce [ readUsedID readString readString ]] comment "---- end of include %parsers/font-and-text.r ----" comment { #### Include: %parsers/shape.r #### Title: "SWF shape parse functions" #### Author: "" ----} readFILLSTYLEARRAY: has [FillStyles] [ byteAlign FillStyles: copy [] loop readCount [ append/only FillStyles readFILLSTYLE ] FillStyles ] readFILLSTYLE: has [type] [ byteAlign reduce [ type: readUI8 case [ type = 0 [ case [ find [46 84] tagId [ reduce [readRGBA readRGBA] ] tagId >= 32 [readRGBA] true [readRGB] ] ] any [ type = 16 type = 18 type = 19 ] [ reduce either find [46 84] tagId [ [readMATRIX readMATRIX readGRADIENT] ] [ [readMATRIX readGRADIENT] ] ] type >= 64 [ reduce either find [46 84] tagId [ [readUsedID readMATRIX readMATRIX] ] [ [readUsedID readMATRIX] ] ] ] ] ] readLINESTYLEARRAY: has [LineStyles] [ LineStyles: copy [] byteAlign print [tagID mold copy/part inBuffer 10] loop readCount [ append/only LineStyles readLINESTYLE ] LineStyles ] readLINESTYLE: has [flags] [ byteAlign reduce case [ tagId = 46 [ [ readUI16 readUI16 readRGBA readRGBA ] ] any [tagId = 67 tagId = 83] [ [ readUI16 reduce [ readUB 2 joinStyle: readUB 2 hasFill?: readBitLogic readBitLogic readBitLogic readBitLogic ( skipBits 5 readBitLogic ) readUB 2 ] either joinStyle = 2 [readUI16] [none] either hasFill? [readFILLSTYLE] [readRGBA] ] ] tagId = 84 [ [ readUI16 readUI16 reduce [ readUB 2 joinStyle: readUB 2 hasFill?: readBitLogic readBitLogic readBitLogic readBitLogic ( skipBits 5 readBitLogic ) readUB 2 ] either joinStyle = 2 [readUI16] [none] either hasFill? [readFILLSTYLE] [reduce [readRGBA readRGBA]] ] ] true [ [ readUI16 either tagId = 32 [readRGBA] [readRGB] ] ] ] ] readGRADIENT: has [gradients] [ gradients: copy [] byteAlign loop readUI8 [ insert tail gradients readGRADRECORD ] gradients ] readGRADRECORD: has [] [ reduce [ readUI8 either tagId >= 32 [readRGBA] [readRGB] ] ] readSHAPERECORD: func [numFillBits numLineBits /local nBits lineType states records] [ records: copy [] lineType: none byteAlign until [ either readBitLogic [ either readBitLogic [ if lineType <> 'line [insert tail records lineType: 'line] nBits: 2 + readUB 4 insert tail records reduce either readBitLogic [ [ readSB nBits readSB nBits ] ] [ either readBitLogic [ [0 readSB nBits] ] [ [readSB nBits 0] ] ] ] [ if lineType <> 'curve [insert tail records lineType: 'curve] nBits: 2 + readUB 4 insert tail records reduce [ readSB nBits readSB nBits readSB nBits readSB nBits ] ] false ] [ states: readUB 5 either states = 0 [ true ] [ lineType: none insert tail records 'style insert/only tail records reduce [ either 0 < (states and 1) [readSBPair] [none] either 0 < (states and 2) [readUB numFillBits] [none] either 0 < (states and 4) [readUB numFillBits] [none] either 0 < (states and 8) [readUB numLineBits] [none] either 0 < (states and 16) [ reduce [ readFILLSTYLEARRAY readLINESTYLEARRAY numFillBits: readUB 4 numLineBits: readUB 4 ] ] [none] ] false ] ] ] records ] readSHAPE: does [ readSHAPERECORD (byteAlign readUB 4) readUB 4 ] readSHAPEWITHSTYLES: does [ byteAlign reduce [ readFILLSTYLEARRAY readLINESTYLEARRAY readSHAPERECORD (byteAlign readUB 4) readUB 4 ] ] parse-DefineShape: does [ reduce [ readID readRect either tagId >= 67 [ reduce [ readRect ( readUB 6 readBitLogic ) readBitLogic ] ] [none] readSHAPEWITHSTYLES ] ] comment "---- end of include %parsers/shape.r ----" comment { #### Include: %parsers/button.r #### Title: "SWF buttons parse functions" #### Author: "" ----} readBUTTONRECORDs: has [records reserved states] [ records: copy [] until [ byteAlign reserved: readUB 4 states: readUB 4 either all [reserved = 0 states = 0] [true] [ repend/only records [ states readUsedID readUI16 readMATRIX either tagId = 34 [readCXFORMa] [none] ] false ] ] records ] readBUTTONCONDACTIONs: has [actions CondActionSize] [ actions: copy [] byteAlign until [ either any [ tail? inBuffer 0 = CondActionSize: readUI16 ] [true] [ repend actions [ readBitLogic readBitLogic readBitLogic readBitLogic readBitLogic readBitLogic readBitLogic readBitLogic readUB 7 readBitLogic readACTIONRECORDs ] false ] ] actions ] parse-DefineButton: does [ reduce [ readID readBUTTONRECORDs readACTIONRECORDs ] ] parse-DefineButton2: does [ reduce [ readID ( readUI8 readUI16 readBUTTONRECORDs ) readBUTTONCONDACTIONs ] ] parse-DefineButtonCxform: does [ reduce [ readUsedID readCXFORM ] ] parse-DefineButtonSound: has [id] [ reduce [ readUsedID either 0 < id: readUsedID [reduce [id readSOUNDINFO]] [none] either 0 < id: readUsedID [reduce [id readSOUNDINFO]] [none] either 0 < id: readUsedID [reduce [id readSOUNDINFO]] [none] either 0 < id: readUsedID [reduce [id readSOUNDINFO]] [none] ] ] comment "---- end of include %parsers/button.r ----" comment { #### Include: %parsers/sprite.r #### Title: "SWF sprites and movie clip related parse functions" #### Author: "" ----} parse-DefineSprite: has [] [ reduce [ readID readUI16 readSWFTAGs inBuffer ] ] parse-PlaceObject: does [ reduce [ readUsedID readUI16 readMATRIX either tail? inBuffer [none] [readCXFORM] ] ] parse-PlaceObject2: has [flags] [reduce [ ( flags: readUI8 readUI16 ) isSetBit? flags 1 either isSetBit? flags 2 [readUsedID] [none] either isSetBit? flags 3 [readMATRIX] [none] either isSetBit? flags 4 [readCXFORMa] [none] either isSetBit? flags 5 [readUI16] [none] either isSetBit? flags 6 [readString] [none] either isSetBit? flags 7 [readUI16] [none] either isSetBit? flags 8 [readCLIPACTIONS] [none] ]] parse-PlaceObject3: has [flags flags2] [reduce [ ( flags: readUI8 flags2: readUI8 readUI16 ) ( isSetBit? flags 1 ) either isSetBit? flags 2 [readUsedID] [none] either isSetBit? flags 3 [readMATRIX] [none] either isSetBit? flags 4 [readCXFORMa] [none] either isSetBit? flags 5 [readUI16] [none] either isSetBit? flags 6 [readString] [none] either isSetBit? flags 7 [readUI16] [none] either isSetBit? flags2 1 [readFILTERS] [none] either isSetBit? flags2 2 [readUI8] [none] either isSetBit? flags2 3 [readUI8] [none] either isSetBit? flags 8 [readCLIPACTIONS] [none] ]] readFILTERS: has [filters type columns rows] [ filters: copy [] loop readUI8 [ byteAlign repend filters [ type: readUI8 reduce case [ type = 1 [ [ readULongFixed readULongFixed readUB 5 ] ] find [0 2 3] type [ inBuffer [ readRGBA readSLongFixed readSLongFixed either type <> 2 [ reduce [ readSLongFixed readSLongFixed ] ] [none] readSShortFixed readBitLogic readBitLogic readBitLogic readBitLogic ] ] find [4 7] type [ count: readUI8 [ readRGBAArray count readUI8Array count readSLongFixed readSLongFixed readSLongFixed readSLongFixed readSShortFixed readBitLogic readBitLogic readBitLogic (skipBits 1 readUB 4 ) ] ] type = 5 [ [ columns: readUI8 rows: readUI8 readLongFloat readLongFloat readLongFloatArray (columns * rows) readRGBA skipBits 6 readBitLogic readBitLogic ] ] type = 6 [ readLongFloatArray 20 ] ] ] ] filters ] parse-RemoveObject: does [ reduce [ readUsedID readUI16 ] ] parse-RemoveObject2: does [ readUI16 ] parse-SWT-CharacterName: does [ reduce [ readID readSTRING ] ] readCLIPACTIONS: does [reduce [ readUI16 readUI32 readCLIPACTIONRECORDs ]] readCLIPACTIONRECORDs: has [records flags] [ records: copy [] until [ insert/only tail records reduce [ flags: readUI32 readUI32 either isSetBit? flags 10 [readUI8] [none] readACTIONRECORDs ] 0 = either swfVersion > 5 [readUI32] [readUI16] ] records ] comment "---- end of include %parsers/sprite.r ----" comment { #### Include: %parsers/sound.r #### Title: "SWF sound related parse functions" #### Author: "" ----} parse-DefineSound: does [ reduce [ readID readUB 4 readUB 2 readBitLogic readBitLogic readUI32 readRest ] ] parse-StartSound: does [ reduce [ readUsedID readSOUNDINFO ] ] parse-SoundStreamHead: does [ reduce [ (readUB 4 none) readUB 2 readBitLogic readBitLogic StreamSoundCompression: readUB 4 readUB 2 readBitLogic readBitLogic readUI16 either StreamSoundCompression = 2 [readSI16] [none] ] ] parse-SoundStreamBlock: does [ reduce [ switch/default StreamSoundCompression [ 2 [readMP3STREAMSOUNDDATA] ] [readRest] ] ] readMP3STREAMSOUNDDATA: does [ reduce [ StreamSoundCompression readUI16 readMP3SOUNDDATA ] ] readMP3SOUNDDATA: does [ reduce [ readSI16 readMP3FRAMEs ] ] readMP3FRAMEs: has [frames MpegVersion Layer Bitrate SamplingRate sampleDataSize] [ frames: copy [] while [not tail? inBuffer] [ repend frames [ readUB 11 MpegVersion: readUB 2 Layer: readUB 2 readBitLogic ( Bitrate: readUB 4 SamplingRate: readUB 2 PaddingBit: readBit readBit readUB 2 ) readUB 2 readBitLogic readBitLogic readUB 2 Bitrate: transMP3Bitrate Layer MpegVersion Bitrate SamplingRate: transMP3SamplingRate MpegVersion SamplingRate ( sampleDataSize: to integer! either MpegVersion = 3 [ (((either Layer = 3 [48000] [144000]) * Bitrate) / SamplingRate) + PaddingBit - 4 ] [ (((either Layer = 3 [24000] [72000]) * Bitrate) / SamplingRate) + PaddingBit - 4 ] readBytes sampleDataSize ) ] ] frames ] transMP3Bitrate: func [Layer MpegVersion Bitrate] [ pick (switch Layer either MpegVersion = 3 [[ 3 [[32 64 96 128 160 192 224 256 288 320 352 384 416 448]] 2 [[32 48 56 64 80 96 112 128 160 192 224 256 320 384]] 1 [[32 40 48 56 64 80 96 112 128 160 192 224 256 320]] ]] [[ 3 [[32 48 56 64 80 96 112 128 144 160 176 192 224 256]] 2 [[8 16 24 32 40 48 56 64 80 96 112 128 144 160]] 1 [[8 16 24 32 40 48 56 64 80 96 112 128 144 160]] ]]) Bitrate ] transMP3SamplingRate: func [MpegVersion SamplingRate] [ pick switch MpegVersion [ 3 [[44100 48000 32000 "--"]] 2 [[22050 24000 16000 "--"]] 0 [[11025 12000 8000 "--"]] ] (1 + SamplingRate) ] readSOUNDINFO: has [HasEnvelope? HasLoops? HasOutPoint? HasInPoint?] [ reduce [ (readUB 2 none) readBitLogic readBitLogic ( HasEnvelope?: readBitLogic HasLoops?: readBitLogic HasOutPoint?: readBitLogic HasInPoint?: readBitLogic either HasInPoint? [readUI32] [none] ) either HasOutPoint? [readUI32] [none] either HasLoops? [readUI16] [none] either HasEnvelope? [readSOUNDENVELOPE] [none] ] ] readSOUNDENVELOPE: does [ result: copy [] loop readUI8 [ insert tail result reduce [ readUI32 readUI16 readUI16 ] ] result ] comment "---- end of include %parsers/sound.r ----" comment { #### Include: %parsers/bitmap.r #### Title: "SWF bitmaps parse functions" #### Author: "" ----} parse-DefineBitsLossless: has [BitmapFormat] [ reduce [ readID BitmapFormat: readUI8 readUI16 readUI16 either BitmapFormat = 3 [readUI8] [none] readRest ] ] parse-DefineBits: does [ reduce [ readID readRest ] ] parse-JPEGTables: does [ readRest ] parse-DefineBitsJPEG2: does [ reduce [ readID readRest ] ] parse-DefineBitsJPEG3: does [ reduce [ readID readBytes readUI32 readRest ] ] comment "---- end of include %parsers/bitmap.r ----" comment { #### Include: %parsers/actions.r #### Title: "SWF actions related parse functions" #### Author: "" ----} parse-DoAction: readACTIONRECORDs: has [records Length ActionCode] [ records: copy [] until [ either #{00} = ActionCode: readByte [true] [ insert tail records reduce [ ActionCode readBytes either (to integer! actionCode) > 127 [readUI16] [0] ] false ] ] records ] parse-DoInitAction: does [reduce [ readUsedID readACTIONRECORDs ]] parse-DoABC: has [abc] [ write/binary join rswf-root-dir %tmp.abc abc: readRest if error? try [ call/wait rejoin [to-local-file rswf-root-dir/bin/abcdump.exe " " to-local-file rswf-root-dir/tmp.abc] read rswf-root-dir/tmp.abc.il ] [abc] ] parse-DoABC2: does [reduce [ readSI32 readString parse-DoABC ]] parse-SymbolClass: has [classes] [ classes: copy [] loop readUI16 [ insert tail classes reduce [ readUsedID readString ] ] classes ] comment "---- end of include %parsers/actions.r ----" comment { #### Include: %parsers/morphing.r #### Title: "SWF morphing shapes related parse functions" #### Author: "" ----} parse-DefineMorphShape: does [ reduce [ readID readRECT readRECT readUI32 readFILLSTYLEARRAY readLINESTYLEARRAY readSHAPE readSHAPE ] ] parse-DefineMorphShape2: does [ reduce [ readID readRECT readRECT readRECT readRECT ( readUB 6 readBitLogic ) readBitLogic readUI32 readFILLSTYLEARRAY readLINESTYLEARRAY readSHAPE readSHAPE ] ] comment "---- end of include %parsers/morphing.r ----" comment { #### Include: %parsers/control-tags.r #### Title: "SWF control tags related parse functions" #### Author: "" ----} parse-ExportAssets: has [result] [ result: copy [] loop readUI16 [ repend result [readUsedID readSTRING] ] result ] parse-ImportAssets: has [result] [reduce [ readSTRING either swfVersion >= 8 [ reduce [ readUI8 readUI8 ] ] [none] ( result: copy [] loop readUI16 [ repend result [readID readSTRING] ] result ) ]] parse-ImportAssets2: :parse-ImportAssets parse-EnableDebugger: does [readRest] parse-EnableDebugger2: does [reduce [ readUI16 readRest ]] parse-ScriptLimits: does [reduce [ readUI16 readUI16 ]] parse-SetTabIndex: does [reduce [ readUI16 readUI16 ]] parse-FileAttributes: does [reduce [ readUB 3 readBitLogic readBitLogic readBitLogic readBitLogic readBitLogic readUB 24 ]] parse-DefineBinaryData: does [reduce [ readID readSI32 readRest ]] parse-DefineScalingGrid: does [reduce [ readUsedID readRECT ]] parse-DefineSceneAndFrameLabelData: has [scenes] [ scenes: copy [] loop readUI8 [ insert tail scenes reduce [ readString readUI30 ] ] scenes ] parse-SerialNumber: does [ reduce [ readSI32 readSI32 readUI8 readUI8 readBytes 8 readBytes 8 ] ] comment "---- end of include %parsers/control-tags.r ----" comment { #### Include: %parsers/swf-importing.r #### Title: "SWF sprites and movie clip related parse functions" #### Author: "" ----} set 'import-swf-tag func [tagId tagData /local err action st st2] [ reduce either none? action: select parseActions tagId [ form-tag tagId tagData ] [ setStreamBuffer tagData if error? set/any 'err try [ set/any 'result do bind/copy action 'self ] [ print ajoin ["!!! ERROR while importing tag:" select swfTagNames tagId "(" tagId ")"] throw err ] form-tag tagId head inBuffer ] ] form-tag: func [ "Creates the SWF-TAG" id [integer!] "Tag ID" data [binary!] "Tag data block" /local len ] [ either any [ 62 < len: length? data not none? find [2 20 34 36 37 48] id ] [ rejoin [ int-to-ui16 (63 or (id * 64)) int-to-ui32 len data ] ] [ rejoin [ int-to-ui16 (len or (id * 64)) data ] ] ] 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] ] [ 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] ] get-replacedID: func [id] [ foreach [oid nid] replaced-ids [ if id = oid [ return nid ] ] id ] replacedID: func [/ui /local id newid] [ id: copy/part inBuffer 2 newid: get-replacedID id inBuffer: change inBuffer newid newid ] changeID: func [/local id new-id idbin newbin] [ id: to-integer head reverse copy idbin: copy/part inBuffer 2 tag-bin: either find used-ids id [ new-id: 1 + (last used-ids) insert tail used-ids new-id newbin: int-to-ui16 new-id append replaced-ids reduce [idbin newbin] inBuffer: change inBuffer newbin ] [ insert tail used-ids id used-ids: sort used-ids inBuffer: skip inBuffer 2 ] ] skipMATRIX: does [ byteAlign if readBitLogic [skipPair] if readBitLogic [skipPair] skipPair byteAlign ] skipGRADIENT: has [gradients] [ byteAlign loop readUI8 [ skipUI8 either tagId >= 32 [skipRGBA] [skipRGB] ] ] skipCXFORM: has [HasAddTerms? HasMultTerms? nbits] [ HasAddTerms?: readBitLogic HasMultTerms?: readBitLogic nbits: readUB 4 if HasMultTerms? [skipBits (3 * nbits)] if HasAddTerms? [skipBits (3 * nbits)] ] skipCXFORMa: has [HasAddTerms? HasMultTerms? nbits] [ HasAddTerms?: readBitLogic HasMultTerms?: readBitLogic nbits: readUB 4 if HasMultTerms? [skipBits (4 * nbits)] if HasAddTerms? [skipBits (4 * nbits)] ] skipSOUNDINFO: has [HasEnvelope? HasLoops? HasOutPoint? HasInPoint?] [ skipBits 4 HasEnvelope?: readBitLogic HasLoops?: readBitLogic HasOutPoint?: readBitLogic HasInPoint?: readBitLogic if HasInPoint? [skipUI32] if HasOutPoint? [skipUI32] if HasLoops? [skipUI16] if HasEnvelope? [skipBytes (readUI8 * 8)] ] import-FILLSTYLEARRAY: does [ byteAlign loop readCount [ import-FILLSTYLE ] ] import-LINESTYLEARRAY: has [flags joinStyle hasFill?] [ loop readCount [ byteAlign case [ tagId = 46 [skipBytes 12] any [tagId = 67 tagId = 83] [ skipUI16 skipBits 2 joinStyle: readUB 2 hasFill?: readBitLogic skipBits 11 if joinStyle = 2 [skipUI16] either hasFill? [import-FILLSTYLE] [skipRGBA] ] tagId = 84 [ skipUI16 skipUI16 skipBits 2 joinStyle: readUB 2 hasFill?: readBitLogic skipBits 11 if joinStyle = 2 [skipUI16] either hasFill? [import-FILLSTYLE] [skipBytes 8] ] true [ skipUI16 either tagId = 32 [skipRGBA] [skipRGB] ] ] ] ] import-FILLSTYLE: has [type] [ byteAlign type: readUI8 case [ type = 0 [ case [ find [46 84] tagId [ skipBytes 8 ] tagId >= 32 [skipRGBA] true [skipRGB] ] ] any [ type = 16 type = 18 type = 19 ] [ either find [46 84] tagId [ skipMATRIX skipMATRIX skipGRADIENT ] [ skipMATRIX skipGRADIENT ] ] type >= 64 [ either find [46 84] tagId [ replacedID skipMATRIX skipMATRIX ] [ replacedID skipMATRIX ] ] ] ] import-SHAPERECORD: func [numFillBits numLineBits /local nBits lineType states records] [ byteAlign until [ either readBitLogic [ either readBitLogic [ nBits: 2 + readUB 4 either readBitLogic [ skipBits (2 * nBits) ] [ skipBits (1 + nBits) ] ] [ nBits: 2 + readUB 4 skipBits (4 * nBits) ] false ] [ states: readUB 5 either states = 0 [ true ] [ if 0 < (states and 1) [skipPair] if 0 < (states and 2) [skipBits numFillBits] if 0 < (states and 4) [skipBits numFillBits] if 0 < (states and 8) [skipBits numLineBits] if 0 < (states and 16) [ import-FILLSTYLEARRAY import-LINESTYLEARRAY numFillBits: readUB 4 numLineBits: readUB 4 ] false ] ] ] ] import-Shape: has [type] [ changeID skipRect if tagId = 83 [ skipRect skipByte ] import-FILLSTYLEARRAY import-LINESTYLEARRAY import-SHAPERECORD (byteAlign readUB 4) readUB 4 ] import-DefineButton: does [ changeID import-BUTTONRECORDs ] import-DefineButton2: does [ changeID skipBytes 3 import-BUTTONRECORDs ] import-DefineButtonSound: has [id] [ replacedID loop 4 [ if #{0000} <> replacedID [skipSOUNDINFO] ] ] import-BUTTONRECORDs: has [reserved states] [ until [ byteAlign reserved: readUB 4 states: readUB 4 either all [reserved = 0 states = 0] [true] [ replacedID skipUI16 skipMATRIX either tagId = 34 [skipCXFORMa] [none] false ] ] ] import-PlaceObject2: has [flags] [ flags: readUI8 if tagId = 70 [skipUI8] either spriteLevel = 0 [last-depth: readUI16] [skipUI16] if isSetBit? flags 2 [replacedID] ] import-DefineText: has [GlyphBits AdvanceBits HasFont? HasColor? HasYOffset? HasXOffset?] [ changeID skipRECT skipMATRIX byteAlign GlyphBits: readUI8 AdvanceBits: readUI8 while [readBitLogic] [ skipBits 3 HasFont?: readBitLogic HasColor?: readBitLogic HasYOffset?: readBitLogic HasXOffset?: readBitLogic if HasFont? [replacedID] if HasColor? [either tagId = 11 [skipRGB] [skipRGBA]] if HasXOffset? [skipSI16] if HasYOffset? [skipSI16] if HasFont? [skipUI16] skipBits (readUI8 * (GlyphBits + AdvanceBits)) ] ] import-DefineEditText: has [HasText? HasTextColor? HasMaxLength? HasFont? HasLayout?] [ changeID skipRECT HasText?: readBitLogic skipBits 4 HasTextColor?: readBitLogic HasMaxLength?: readBitLogic HasFont?: readBitLogic skipBits 2 HasLayout?: readBitLogic byteAlign if HasFont? [replacedID skipUI16] if HasTextColor? [skipRGBA] if HasMaxLength? [skipUI16] if HasLayout? [skipBytes 9] skipString if HasText? [skipString] ] import-DefineSprite: has [i h] [ changeID skipUI16 i: index? inbuffer h: copy/part head inBuffer (i - 1) inBuffer: at join h importSWFTAGs inBuffer i ] import-DefineMorphShape: does [ changeID skipRECT skipRECT skipUI32 import-FILLSTYLEARRAY skipBytes (readCount * 12) import-SHAPERECORD readUB 4 readUB 4 import-SHAPERECORD readUB 4 readUB 4 ] import-DefineMorphShape2: does [ changeID skipRECT skipRECT skipRECT skipRECT skipBytes 5 import-FILLSTYLEARRAY import-LINESTYLEARRAY import-SHAPERECORD readUB 4 readUB 4 import-SHAPERECORD readUB 4 readUB 4 ] import-ExportAssets: has [id name] [ loop readUI16 [ id: replacedID name: join "imp_" readSTRING if none? find imported-names [name] [ repend imported-names [to-word name to integer! head reverse id] ] ] ] import-ImportAssets: does [ skipSTRING if swfVersion >= 8 [ skipUI16 ] loop readUI16 [changeID skipSTRING] ] import-SymbolClass: does [ loop readUI16 [replacedID skipString] ] comment "---- end of include %parsers/swf-importing.r ----" ] comment "---- end of include %swf-tag-parser.r ----" ] save-jpgs: func [swffile] [ exam-swf/file/parseActions/only swffile [ 21 [ use [id data] [ ( id: readID data: readRest write/binary rejoin [%id id %.jpg] data reduce [id data] ) ] ] ] [21] ] comment "---- end of RS include %swf-parser.r ----" set 'rswf-project-dir what-dir set 'rswf-root-dir what-dir if error? try [rswf-web-url] [ set 'rswf-web-url http://box.lebeda.ws/~hmm/rswf/ ] system/options/quiet: true rswf: context [ body: last-id: action-bin: swf-framerate: including: included-files: animations: action-bin-buff: sprite-recursion-buff: max-bits: set-word-buff: current-set-word: set-word: last-depth: used-ids: stream: names-ids-table: placed-images: placed-objects: WindowClassCreated?: int-to-ui16: int-to-ui8: int-to-bits: int-to-ui32: ui32-struct: ui16-struct: none compile-actions: get in system/words 'compile-actions tmp: v: v2: v3: val: val2: val3: twips?: fixed-bounds?: FillStyles: def-LineSt: cur-LineSt: to-twips: prepare-pos: draw-curves: draw-arc: n-gon: n-star: draw-box: update-gradient: get-fill: sc: set-fill-style: set-line-style: shp-rules: bf: id-word: exported-assets: shp-size: none comment { #### Include: %../../../projects/ucs2/latest/ucs2cp1250only.r #### Title: "UCS-2 (CP1250 charset only!)" #### Author: "oldes" ----} ucs2: context [ charmap: "cp1250" result: c: none encode-rule: [ any [ #{82} (insert tail result #{201A}) | #{84} (insert tail result #{201E}) | #{85} (insert tail result #{2026}) | #{86} (insert tail result #{2020}) | #{87} (insert tail result #{2021}) | #{89} (insert tail result #{2030}) | #{8A} (insert tail result #{0160}) | #{8B} (insert tail result #{2039}) | #{8C} (insert tail result #{015A}) | #{8D} (insert tail result #{0164}) | #{8E} (insert tail result #{017D}) | #{8F} (insert tail result #{0179}) | #{91} (insert tail result #{2018}) | #{92} (insert tail result #{2019}) | #{93} (insert tail result #{201C}) | #{94} (insert tail result #{201D}) | #{95} (insert tail result #{2022}) | #{96} (insert tail result #{2013}) | #{97} (insert tail result #{2014}) | #{99} (insert tail result #{2122}) | #{9A} (insert tail result #{0161}) | #{9B} (insert tail result #{203A}) | #{9C} (insert tail result #{015B}) | #{9D} (insert tail result #{0165}) | #{9E} (insert tail result #{017E}) | #{9F} (insert tail result #{017A}) | #{A1} (insert tail result #{02C7}) | #{A2} (insert tail result #{02D8}) | #{A3} (insert tail result #{0141}) | #{A5} (insert tail result #{0104}) | #{AA} (insert tail result #{015E}) | #{AF} (insert tail result #{017B}) | #{B2} (insert tail result #{02DB}) | #{B3} (insert tail result #{0142}) | #{B9} (insert tail result #{0105}) | #{BA} (insert tail result #{015F}) | #{BC} (insert tail result #{013D}) | #{BD} (insert tail result #{02DD}) | #{BE} (insert tail result #{013E}) | #{BF} (insert tail result #{017C}) | #{C0} (insert tail result #{0154}) | #{C3} (insert tail result #{0102}) | #{C5} (insert tail result #{0139}) | #{C6} (insert tail result #{0106}) | #{C8} (insert tail result #{010C}) | #{CA} (insert tail result #{0118}) | #{CC} (insert tail result #{011A}) | #{CF} (insert tail result #{010E}) | #{D0} (insert tail result #{0110}) | #{D1} (insert tail result #{0143}) | #{D2} (insert tail result #{0147}) | #{D5} (insert tail result #{0150}) | #{D8} (insert tail result #{0158}) | #{D9} (insert tail result #{016E}) | #{DB} (insert tail result #{0170}) | #{DE} (insert tail result #{0162}) | #{E0} (insert tail result #{0155}) | #{E3} (insert tail result #{0103}) | #{E5} (insert tail result #{013A}) | #{E6} (insert tail result #{0107}) | #{E8} (insert tail result #{010D}) | #{EA} (insert tail result #{0119}) | #{EC} (insert tail result #{011B}) | #{EF} (insert tail result #{010F}) | #{F0} (insert tail result #{0111}) | #{F1} (insert tail result #{0144}) | #{F2} (insert tail result #{0148}) | #{F5} (insert tail result #{0151}) | #{F8} (insert tail result #{0159}) | #{F9} (insert tail result #{016F}) | #{FB} (insert tail result #{0171}) | #{FE} (insert tail result #{0163}) | #{FF} (insert tail result #{02D9}) | copy c 1 skip (insert tail result join #{00} c) ] ] decode-rule: [ any [ #{201A} (insert tail result #{82}) | #{201E} (insert tail result #{84}) | #{2026} (insert tail result #{85}) | #{2020} (insert tail result #{86}) | #{2021} (insert tail result #{87}) | #{2030} (insert tail result #{89}) | #{0160} (insert tail result #{8A}) | #{2039} (insert tail result #{8B}) | #{015A} (insert tail result #{8C}) | #{0164} (insert tail result #{8D}) | #{017D} (insert tail result #{8E}) | #{0179} (insert tail result #{8F}) | #{2018} (insert tail result #{91}) | #{2019} (insert tail result #{92}) | #{201C} (insert tail result #{93}) | #{201D} (insert tail result #{94}) | #{2022} (insert tail result #{95}) | #{2013} (insert tail result #{96}) | #{2014} (insert tail result #{97}) | #{2122} (insert tail result #{99}) | #{0161} (insert tail result #{9A}) | #{203A} (insert tail result #{9B}) | #{015B} (insert tail result #{9C}) | #{0165} (insert tail result #{9D}) | #{017E} (insert tail result #{9E}) | #{017A} (insert tail result #{9F}) | #{02C7} (insert tail result #{A1}) | #{02D8} (insert tail result #{A2}) | #{0141} (insert tail result #{A3}) | #{0104} (insert tail result #{A5}) | #{015E} (insert tail result #{AA}) | #{017B} (insert tail result #{AF}) | #{02DB} (insert tail result #{B2}) | #{0142} (insert tail result #{B3}) | #{0105} (insert tail result #{B9}) | #{015F} (insert tail result #{BA}) | #{013D} (insert tail result #{BC}) | #{02DD} (insert tail result #{BD}) | #{013E} (insert tail result #{BE}) | #{017C} (insert tail result #{BF}) | #{0154} (insert tail result #{C0}) | #{0102} (insert tail result #{C3}) | #{0139} (insert tail result #{C5}) | #{0106} (insert tail result #{C6}) | #{010C} (insert tail result #{C8}) | #{0118} (insert tail result #{CA}) | #{011A} (insert tail result #{CC}) | #{010E} (insert tail result #{CF}) | #{0110} (insert tail result #{D0}) | #{0143} (insert tail result #{D1}) | #{0147} (insert tail result #{D2}) | #{0150} (insert tail result #{D5}) | #{0158} (insert tail result #{D8}) | #{016E} (insert tail result #{D9}) | #{0170} (insert tail result #{DB}) | #{0162} (insert tail result #{DE}) | #{0155} (insert tail result #{E0}) | #{0103} (insert tail result #{E3}) | #{013A} (insert tail result #{E5}) | #{0107} (insert tail result #{E6}) | #{010D} (insert tail result #{E8}) | #{0119} (insert tail result #{EA}) | #{011B} (insert tail result #{EC}) | #{010F} (insert tail result #{EF}) | #{0111} (insert tail result #{F0}) | #{0144} (insert tail result #{F1}) | #{0148} (insert tail result #{F2}) | #{0151} (insert tail result #{F5}) | #{0159} (insert tail result #{F8}) | #{016F} (insert tail result #{F9}) | #{0171} (insert tail result #{FB}) | #{0163} (insert tail result #{FE}) | #{02D9} (insert tail result #{FF}) | #{00} copy c 1 skip (insert tail result c) | copy c 2 skip (decodeUnknownChar c) ] ] encode: func [ {Encodes any text to UCS-2 octet string acording the charset} str [string! binary!] "String to encode" ] [ str: to-binary str result: make binary! 2 * length? str parse/all/case str encode-rule result ] decode: func [ {Decodes any text to UCS-2 octet string acording the charset} str [string! binary!] "String to encode" ] [ result: make binary! 2 * length? str parse/all/case str decode-rule result ] ] comment {---- end of include %../../../projects/ucs2/latest/ucs2cp1250only.r ----} comment { #### Include: %make-swf.r #### Title: "SWF creator" #### Author: "oldes" ----} ins: func [b [binary!]] [insert tail body b] ins-act: func [b [binary!] /local tmp l] [ if not empty? action-push-buff [ either 150 = first b [ l: to integer! head reverse copy/part next b 2 if (3 + l) < length? b [ insert tail action-push-buff copy/part skip b 3 l b: remove/part b (3 + l) form-push/compact/nobuff action-push-buff clear action-push-buff ] ] [ form-push/compact/nobuff action-push-buff clear action-push-buff ] ] insert tail action-bin b ] quiet?: off swf-version: 6 useConstantPool?: true useFunc2?: true use-web-includes?: true utf8-encode?: true frames: 0 comment { #### Include: %sound-fce.rinc #### Title: "Sound related functions" #### Author: "oldes" ----} mp3: make object! [ header: frame: none sdsize: 0 Syncword: MpegVersion: Layer: ProtectionBit: Bitrate: SamplingRate: PaddingBit: reserved: ChannelMode: ModeExtension: Copyright: Original: Emphasis: none getMp3Frame: func [port] [ frame: none if not none? header: copy/part port 4 [ if 255 <> first header [ switch (to-string copy/part header 3) [ "ID3" [ append header copy/part port 6 id3: copy/part port third parse-ID3header header ] "TAG" [ copy/part port 124 ] ] header: copy/part port 4 ] if not none? header [ parse-Mp3FrameHeader header frame: copy/part port to-integer sdsize ] ] frame ] SynchsafeInt: func [bin [binary!] "4 bytes"] [ to integer! debase/base ( join "000" head remove skip (remove skip (remove skip (enbase/base bin 2) 8) 7) 7 ) 2 ] parse-ID3header: func [header [binary!] /local version flags size] [ set [version flags tmp] next slice-bin header [3 2 1 4] flags: enbase/base flags 2 size: (SynchsafeInt tmp) + either flags/2 = "1" [10] [0] reduce [version flags size] ] parse-Mp3FrameHeader: func [header [binary!]] [ if header = #{00000000} [return false] set [ Syncword MpegVersion Layer ProtectionBit Bitrate SamplingRate PaddingBit Reserved ChannelMode ModeExtension Copyright Original Emphasis ] slice-bin/integers (enbase/base header 2) [11 2 2 1 4 2 1 1 2 2 1 1 2] Bitrate: pick (switch layer either MpegVersion = 3 [[ 3 [[32 64 96 128 160 192 224 256 288 320 352 384 416 448]] 2 [[32 48 56 64 80 96 112 128 160 192 224 256 320 384]] 1 [[32 40 48 56 64 80 96 112 128 160 192 224 256 320]] ]] [[ 3 [[32 48 56 64 80 96 112 128 144 160 176 192 224 256]] 2 [[8 16 24 32 40 48 56 64 80 96 112 128 144 160]] 1 [[8 16 24 32 40 48 56 64 80 96 112 128 144 160]] ]]) Bitrate SamplingRate: pick switch MpegVersion [ 3 [[44100 48000 32000 "--"]] 2 [[22050 24000 16000 "--"]] 0 [[11025 12000 8000 "--"]] ] (1 + SamplingRate) sdsize: either MpegVersion = 3 [ (((either layer = 3 [48000] [144000]) * bitrate) / SamplingRate) + PaddingBit - 4 ] [ (((either layer = 3 [24000] [72000]) * bitrate) / SamplingRate) + PaddingBit - 4 ] comment { ^-^-print [tabs ^-^-^-"MpegVersion:" pick [2.5 "" 2 1] (1 + MpegVersion) ^-^-^-"Layer:" pick ["" "III" "II" "I"] (1 + Layer) ^-^-^-"Protected by CRC:" ProtectionBit = 1 ^-^-] ^-^-print [tabs ^-^-^-"Bitrate:" Bitrate ^-^-^-"SamplingRate:" SamplingRate ^-^-^-"PaddingBit:" PaddingBit = 1 ^-^-] ^-^-print [tabs ^-^-^-"ChannelMode:" pick ["Stereo" "Joint stereo (Stereo)" "Dual channel" "Single channel (Mono)"] (1 + ChannelMode) ^-^-^-"Copyright:" Copyright = 1 ^-^-^-"Original:" Original = 1 ^-^-^-"Emphasis:" pick [none "50/15 ms" "" "CCIT J.17"] (1 + Emphasis) ^-^-] ^-^-print [tabs "SampleDataSize:" sdsize] ^-^-;probe sdsize: to-integer ((((either MpegVersion = 3 [144][72]) * Bitrate * 1000) / SamplingRate) + PaddingBit - 4) ^-^-} ] ] wav: make object! [ WORD: [copy v 2 skip (v: to integer! to binary! head reverse v)] DWORD: [copy v 4 skip (v: to integer! to binary! head reverse v)] RIFF-CHUNK: [ copy id 4 skip DWORD copy chunk-data v skip ( (print [id v mold chunk-data]) switch id [ "fmt " [parse/all chunk-data RIFF-FMT-CHUNK] "data" [data-ck: to binary! chunk-data] ] ) ] RIFF-FMT-CHUNK: [ WORD (fmt-ck/wFormatTag: v) WORD (fmt-ck/wChannels: v) DWORD (fmt-ck/dwSamplesPerSec: v) DWORD (fmt-ck/dwAvgBytesPerSec: v) WORD (fmt-ck/wBlockAlign: v) ] id: riff-data: none chunk-data: none data-ck: none fmt-ck: make object! [ wFormatTag: wChannels: dwSamplesPerSec: dwAvgBytesPerSec: wBlockAlign: 0 ] parse-wav: func [bin] [ data-ck: none parse/all bin [ "RIFF" DWORD copy riff-data v skip ( parse/all riff-data [ copy riff-id 4 skip any [RIFF-CHUNK] ] ) ] ] ] create-soundStreamHead: func [/local frameSize rate cmode soundRate] [ rate: mp3/SamplingRate soundRate: either rate < 11000 [0] [either rate < 22000 [1] [either rate < 44100 [2] [3]]] frameSize: either mp3/SamplingRate > 32000 [1152] [576] cmode: either mp3/ChannelMode = 3 [0] [1] stream/samplesPerFrame: to integer! (rate / swf-framerate) stream/idealFrames: stream/samplesPerFrame / frameSize form-tag 18 rejoin [ debase/base rejoin [ "0000" int-to-bits soundRate 2 "1" int-to-bits cmode 1 "0010" int-to-bits soundRate 2 "1" int-to-bits cmode 1 ] 2 int-to-ui16 stream/samplesPerFrame ] ] create-soundStreamBlock: func [/local frameSize f tmp fr frames] [ frameSize: either mp3/SamplingRate > 32000 [1152] [576] stream/frame: stream/frame + 1 f: to integer! (stream/idealFrames * stream/frame) tmp: make binary! frameSize fr: f - stream/mp3frames insert tmp int-to-ui16 either fr <= 0 [0] [abs stream/delay] if stream/mp3frames = 0 [fr: fr + 1] frames: 0 loop fr [ stream/mp3frames: stream/mp3frames + 1 stream/length: stream/length + frameSize frames: frames + 1 insert tail tmp rejoin [ mp3/header mp3/frame ] mp3/getMp3Frame stream/port if none? mp3/frame [break] ] stream/delay: (stream/frame * stream/samplesPerFrame) - stream/length insert tmp int-to-ui16 frames * frameSize ins form-tag 19 tmp ] create-defineSound: func [filename /local file rate soundRate soundSize bin f tmp] [ probe filename either any [ not none? xxx: filename: get-filepath filename ] [ switch last parse filename "." [ "wav" [ file: read/binary filename if wav/parse-wav file [ rate: wav/fmt-ck/dwSamplesPerSec soundRate: either rate < 11000 [0] [either rate < 22000 [1] [either rate < 44100 [2] [3]]] soundSize: either (wav/fmt-ck/dwSamplesPerSec / wav/fmt-ck/wChannels) = wav/fmt-ck/dwSamplesPerSec [0] [1] probe length? wav/data-ck ins form-tag 14 bbb: rejoin [ set-id none (debase/base aaaa: rejoin [ "0000" int-to-bits soundRate 2 int-to-bits soundSize 1 int-to-bits (wav/fmt-ck/wChannels - 1) 1 ] 2) int-to-ui32 length? wav/data-ck wav/data-ck ] ] ] "mp3" [ file: open/direct/binary filename if mp3/getMp3Frame file [ f: 1 rate: mp3/SamplingRate soundRate: either rate < 11000 [0] [either rate < 22000 [1] [either rate < 44100 [2] [3]]] frameSize: either mp3/SamplingRate > 32000 [1152] [576] bin: make binary! length? file tmp: rejoin [ debase/base rejoin [ "0010" int-to-bits soundRate 2 "1" int-to-bits either mp3/ChannelMode = 3 [0] [1] 1 ] 2 ] insert bin join mp3/header mp3/frame while [not none? mp3/getMp3Frame file] [ f: f + 1 insert tail bin mp3/header insert tail bin mp3/frame ] ins form-tag 14 rejoin [ set-id none tmp int-to-ui32 (f * frameSize) #{0000} bin ] ] close file ] ] ] [ print ["Sound file or url (" filename ") doesn't exists!"] ] ] comment "---- end of include %sound-fce.rinc ----" tag-rules: [ any [ 'showFrame ( showFrame ) | 'show set arg1 opt [integer! | none] ['frames | 'frame] ( loop any [arg1 1] [showFrame] ) | 'end ( if not including [ins #{0000}] ) | ['Place | 'PlaceObject2] set arg1 [integer! | word! | block!] [ 'at set arg2 pair! | set arg2 opt [block! | none] ] ( use [old-act-bin act af flags bin tmp f m a name depth pos aid add-act mouseEvents actionIDs blendMode] [ if not block? arg1 [arg1: to block! arg1] either pair? arg2 [arg2: make block! reduce ['at arg2]] [ if none? arg2 [arg2: make block! [at 0x0]] ] blendMode: select [ "Layer" #{02} "Darken" #{06} "Multiply" #{03} "Lighten" #{05} "Screen" #{04} "Overlay" #{0D} "HardLight" #{0E} "Add" #{08} "Subtract" #{09} "Diference" #{07} "Invert" #{0A} "Alpha" #{0B} "Erase" #{0C} ] select arg2 'blend foreach id arg1 [ bin: make binary! 40 flags: make string! "00000010" if not none? act: select arg2 'actions [ flags/1: #"1" af: make binary! #{0000} old-act-bin: copy action-bin insert bin either swf-version > 5 [#{00000000}] [#{0000}] add-act: func [actions types /local type t t1 t2] [ t1: make block! [] t2: make block! [] forall types [ either none? t: select actionIDs types/1 [ either none? t: select mouseEvents types/1 [ make-warning!/msg none ["Unknown action event:" types/1] ] [insert t2 t] ] [insert t1 t] ] if not empty? t2 [ either swf-version < 6 [ make-warning!/msg none [ {Mouse events are not permitted in this SWF version near:} head types ] ] [ type: #{00000000} forall t2 [ type: type or t2/1 af: af or t2/1 ] action-bin: compile-actions actions insert bin rejoin [type int-to-ui32 1 + length? action-bin action-bin #{00}] ] ] if not empty? t1 [ type: #{00000000} forall t1 [ if swf-version < 6 [change t1 copy/part t1/1 2] type: type or t1/1 af: af or t1/1 ] if swf-version < 6 [type: copy/part type 2] action-bin: compile-actions actions insert bin rejoin [type int-to-ui32 1 + length? action-bin action-bin #{00}] ] ] actionIDs: [ Load #{01000000} EnterFrame #{02000000} Unload #{04000000} MouseDown #{10000000} MouseUp #{20000000} MouseMove #{08000000} KeyDown #{40000000} KeyUp #{80000000} Data #{00010000} ] mouseEvents: [ Press #{00040000} Release #{00080000} ReleaseOutside #{00100000} RollOver #{00200000} RollOut #{00400000} DragOver #{00800000} DragOut #{00000100} ] parse act [any [ copy aid word! set tmp block! (add-act tmp aid) | set aid block! set tmp block! (add-act tmp aid) ]] insert bin join #{0000} af action-bin: copy old-act-bin ] if any [ not none? name: select arg2 'name not none? name: set-word ] [ insert bin rejoin [#{} name #{00}] flags/3: #"1" ] if find arg2 'move [flags/8: #"1"] depth: select arg2 'depth last-depth: either none? depth [ either flags/8 = #"1" [last-depth] [last-depth + 1] ] [depth] if parse arg2 [ thru 'ClipDepth set tmp integer! to end | thru 'Mask set tmp integer! to end (tmp: last-depth + tmp) ] [ insert bin int-to-ui16 tmp flags/2: #"1" ] m: select arg2 'multiply a: select arg2 'add if any [not none? a not none? m] [ insert bin bits-to-bin create-cxform/withalpha m a flags/5: #"1" ] if not none? pos: select arg2 'at [ pos: either block? pos [ to pair! reduce [to-twips pos/1 to-twips pos/2] ] [to-twips pos] insert bin bits-to-bin create-matrix pos arg2 flags/6: #"1" ] insert bin int-to-ui16 get-id id insert bin int-to-ui16 last-depth either all [swf-version > 7 not none? blendMode] [ append bin blendMode insert bin #{02} insert bin load rejoin ["2#{" flags "}"] ins form-tag 70 bin ] [ insert bin load rejoin ["2#{" flags "}"] ins form-tag 26 bin ] if not none? set-word [ insert/only placed-objects reduce [name pos] insert placed-objects last-depth remove set-word-buff ] ] ] ) | 'MoveDepth set arg1 opt [integer!] [ 'at set arg2 pair! | set arg2 opt [block! | none] ] ( use [bin flags m a] [ bin: make binary! 40 flags: make string! "00000001" either pair? arg2 [arg2: reduce ['at arg2]] [ if none? arg2 [arg2: reduce ['at 0x0]] ] m: select arg2 'multiply a: select arg2 'add if any [not none? a not none? m] [ insert bin bits-to-bin create-cxform/withalpha m a flags/5: #"1" ] if not none? pos: select arg2 'at [ pos: either block? pos [ to pair! reduce [to integer! 20 * pos/1 to integer! 20 * pos/2] ] [pos * 20] insert bin bits-to-bin create-matrix pos arg2 flags/6: #"1" ] insert bin int-to-ui16 either integer? arg1 [arg1] [last-depth] insert bin load rejoin ["2#{" flags "}"] ins form-tag 26 bin ] ) | ['remove | 'RemoveObject | 'odstranit | 'odstraň | 'destituir | 'liquidar] some [ set arg1 [integer! | word!] set arg2 integer! ( ins form-tag 5 rejoin [ int-to-ui16 get-id arg1 int-to-ui16 arg2 ] ) ] | ['RemoveDepth | 'RemoveDepths] [set arg1 block! | copy arg1 some [integer!]] (foreach tmp arg1 [ins form-tag 28 int-to-ui16 tmp]) | ['sprite | 'sprajt | 'DefineSprite | 'MovieClip] set arg1 opt [integer! | none] set arg2 [ binary! | block! | word! ] opt ['init] set arg3 opt [block! | none] ( compile-sprite arg1 arg2 arg3 ) | ['EmptySprite | 'prázdný 'sprajt] set arg1 [integer! | none] ( ins form-tag 39 rejoin [set-id arg1 #{010040000000}] ) | ['Shape | 'tvar] set arg1 block! (create-shape arg1) | ['image | 'bitmap-to-image] set arg1 [integer! | word!] ( use [size] [ size: select placed-images get-id arg1 parse/all compose/deep [ Shape [ Bounds 0x0 (size) smoothing off image (arg1) ] ] tag-rules ] ) | 'multi-image set arg1 [integer! | word!] set arg2 block! ( use [bmp w ofs sz sz2 clip sm] [ bmp: arg1 sm: 'off clip: "clipped" parse/all arg2 [any [ 'clipped ['off | 'false] (clip: "") | 'clipped ['on | 'true] (clip: "clipped") | ['no 'smoothing | 'smoothing 'off] (sm: 'off) | ['smoothing opt 'on] (sm: 'on) | set w set-word! set ofs pair! set sz pair! set sz2 opt [pair!] ( compile load rejoin [{ ^-^-^-^-^-^-} w {: shape [ ^-^-^-^-^-^-^-bounds 0x0 } sz { ^-^-^-^-^-^-^-smoothing } sm { ^-^-^-^-^-^-^-fill-style [bitmap } bmp " at " 0x0 - ofs " " clip {] ^-^-^-^-^-^-^-box 0x0 } either none? sz2 [sz] [sz2] { ^-^-^-^-^-^-] ^-^-^-^-^-}] ) | arg1: any-type! (make-warning! arg1) ]] ] ) | ['bitmap | 'bitmapa] set arg1 opt [integer! | none] set arg2 [file! | url!] (arg3: none) opt ['size set arg3 pair!] ( either none? arg3 [ load-img arg2 arg1 ] [load-img/size arg2 arg1 arg3] ) | ['alpha 'bitmap | 'DefineBitsLossless2] set arg1 opt [integer! | none] set arg2 [file! | url!] ( load-img/alpha arg2 arg1 ) | ['bitmaps | 'bitmapy] set tmp opt ['images | 'obrázky | none] set arg1 block! ( use [id dir sw sh sm kcolor spr? pr? file size alpha?] [ sm: true dir: copy "" spr?: false pr?: false alpha?: false kcolor: none parse arg1 [any [ 'from set arg2 [file! | url!] (dir: dirize arg2) | 'key set kcolor tuple! | 'no 'key (kcolor: none) | 'make 'sprites (spr?: true) | 'precise (pr?: true) | ['no 'smoothing | 'smoothing 'off] (sm: false) | 'alpha (alpha?: true) | ['smoothing | 'smoothing 'on] (sm: true) | copy id opt [word! | set-word! | none] set arg2 [file! | url!] (arg3: none) opt ['size set arg3 pair!] ( id: to word! either none? id [ rejoin ["bmp_" last parse arg2 "/"] ] [first id] insert arg2 dir file: get-filepath arg2 either pr? [ create-img/param to image! layout/origin reduce [ 'backdrop kcolor 'at 1x1 'image file ] 1x1 id reduce ['key kcolor] ] [ set-id/as id either none? arg3 [ either alpha? [ load-img/alpha file last-id ] [ either none? kcolor [ load-img file last-id ] [load-img/key file last-id kcolor] ] ] [load-img/size file last-id arg3] ] if tmp = 'images [ size: select placed-images get-id id sw: either "bmp_" = copy/part mold id 4 [ replace mold id "bmp_" "img_" ] [join "img_" mold id] parse/all load rejoin [ sw {: Shape [ ^-^-^-^-^-^-^-^-Bounds 0x0 } size { ^-^-^-^-^-^-^-^-} either sm [""] ["smoothing off"] { ^-^-^-^-^-^-^-^-image } id "]" ] tag-rules if spr? [ sh: copy sw parse/all load rejoin [{[ ^-^-^-^-^-^-^-^-} replace sw "img_" "spr_" {: Sprite [ ^-^-^-^-^-^-^-^-^-place } sh " at " either pr? [-1x-1] [0x0] { ^-^-^-^-^-^-^-^-]]} ] tag-rules ] ] ) | arg2: any-type! (make-warning! insert arg2 "BITMAPS:") ]] ] ) | ['bitmap 'layout | 'bitmapové 'rozložení] set arg1 opt [integer! | none] set arg2 block! set arg3 opt [block! | none] ( use [lay tmp] [ lay: layout/origin arg2 0x0 if block? arg3 [ parse/all arg3 [ some [ 'size set tmp pair! (lay/size: tmp) | 'color set tmp [tuple! | issue!] ( lay/color: either tuple? tmp [tmp] [to-tuple issue-to-binary tmp] ) | any-type! ] ] ] create-img/param to image! lay arg1 arg3 ] ) | ['Font | 'DefineFont2] set arg1 [ block! | string! | [ binary! | file! | url! ] opt 'as set arg2 opt [string! | none] set arg3 opt ['noAlign | none] ] ( use [flags bin name enc tmp file file2] [ bin: make binary! 1000 if string? arg1 [arg1: reduce ['name arg1]] either any [file? arg1 url? arg1] [ file: get-filepath arg1 file2: either none? arg3 [get-filepath join arg1 %.align] [none] arg1: read/binary file if string? arg2 [ arg1: rename-font arg1 arg2 ] either not none? file [ either all [found? file2 exists? file2] [ ins form-tag 75 join (set-id none) arg1 ins form-tag 73 join (int-to-ui16 last-id) read/binary file2 ] [ ins form-tag 48 join (set-id none) arg1 ] ] [ make-warning! "Cannot find font file!" ] ] [ either binary? arg1 [ if string? arg2 [ arg1: rename-font arg1 arg2 ] ins form-tag 48 join (set-id none) arg1 ] [ flags: make string! "00000000" insert bin #{00000200} if none? name: select arg1 'name [name: "_sans"] insert bin to binary! name insert bin int-to-ui8 length? name if find arg1 'italic [flags/7: #"1"] if find arg1 'bold [flags/8: #"1"] if find arg1 'small [flags/3: #"1"] either find arg1 'WideCodes [ flags/6: #"1" ] [ if error? try [ enc: 1 + index? find [ShiftJIS Unicode ANSI] select arg1 'encoding ] [enc: 4] poke flags enc #"1" ] insert bin either swf-version > 5 [#{01}] [#{00}] insert bin load rejoin ["2#{" flags "}"] insert bin set-id select arg1 'id ins form-tag 48 bin ] ] ] ) | ['Font3 | 'DefineFont3] set arg1 [binary! | file! | url!] (arg2: none) opt ['alignZone set arg2 [binary! | file! | url!]] ( if not binary? arg1 [arg1: read/binary get-filepath arg1] ins form-tag 75 join (set-id none) arg1 if not none? arg2 [ if not binary? arg2 [arg2: read/binary get-filepath arg2] ins form-tag 73 join (int-to-ui16 last-id) arg2 ] ) | ['AntiAliasing | 'CSMTextSettings] set arg1 [integer! | word!] set arg2 opt [block! | binary! | none] ( ins form-tag 74 join (int-to-ui16 get-id arg1) either binary? arg2 [arg2] [#{48000048430000A74300}] ) | 'EditText set arg1 opt [string! | word! | lit-word! | none] set arg2 pair! set arg3 block! ( use [flags bin tmp f] [ bin: make binary! 40 flags: make string! "0000000000000000" if not none? tmp: select arg3 'text [ insert bin rejoin [#{} either swf-version > 5 [utf8-encode tmp] [tmp] #{00}] flags/1: #"1" ] insert bin either none? arg1 [#{00}] [join to binary! arg1 #{00}] if not none? tmp: select arg3 'layout [ tmp: make make object! [align: 'left margin: 0x0 indent: 0 leading: 2] tmp tmp/align: either found? f: find [left right center justify] tmp/align [ (index? f) - 1 ] [0] insert bin rejoin [ int-to-ui8 tmp/align int-to-ui16 tmp/margin/x * 20 int-to-ui16 tmp/margin/y * 20 int-to-ui16 tmp/indent * 20 int-to-ui16 tmp/leading * 20 ] flags/11: #"1" ] if not none? tmp: select arg3 'MaxLength [ insert bin int-to-ui16 tmp flags/7: #"1" ] if not none? tmp: select arg3 'color [ tmp: either issue? tmp [issue-to-binary tmp] [to binary! tmp] if 4 > length? tmp [insert tail tmp #{FF}] insert bin tmp flags/6: #"1" ] if not none? tmp: select arg3 'font [ insert bin rejoin [int-to-ui16 get-id tmp/1 int-to-ui16 tmp/2 * 20] flags/8: #"1" ] if find arg3 'WordWrap [flags/2: #"1"] if find arg3 'Multiline [flags/3: #"1"] if find arg3 'Password [flags/4: #"1"] if find arg3 'ReadOnly [flags/5: #"1"] if find arg3 'NoSelect [flags/12: #"1"] if find arg3 'Border [flags/13: #"1"] if find arg3 'HTML [flags/15: #"1"] if find arg3 'UseOutlines [flags/16: #"1"] insert bin load rejoin ["2#{" flags "}"] insert bin create-rect/bin 0x0 arg2 * 20 insert bin set-id select arg3 'id ins form-tag 37 bin ] ) | ['Button | 'DefineButton2] set arg1 block! ( use [bin tmp buff v key menu? old-act-bin i actions? ofs id st] [ bin: make binary! 20 insert bin set-id select arg1 'id menu?: either any [none? tmp: select arg1 'as tmp <> 'push] [#{01}] [#{00}] insert tail bin menu? menu?: menu? = #{01} tmp: select arg1 'shapes buff: make string! 100 foreach [states facets] tmp [ st: make string! "00000000" if word? states [states: join copy [] states] foreach state states [ if found? v: find [hit down over up] state [ poke st 4 + index? v #"1" ] ] ofs: either none? ofs: select facets 'at [0x0] [ofs * 20] if none? id: select facets 'id [id: first facets] append buff st append buff enbase/base rejoin [ int-to-ui16 get-id id int-to-ui16 either none? v: select facets 'layer [1] [v] ] 2 append buff create-matrix ofs facets buff: byte-align buff append buff create-cxform/withalpha select facets 'multiply select facets 'add buff: byte-align buff ] buff: bits-to-bin buff append buff #{00} tmp: select arg1 'actions actions?: (block? tmp) and (not empty? tmp) insert tail bin either actions? [int-to-ui16 (length? buff) + 2] [#{0000}] insert tail bin buff if actions? [ old-act-bin: copy action-bin i: 0 foreach [states actions] tmp [ i: i + 2 if not block? states [states: join copy [] states] st: make string! "000000000" key: make string! "0000000" buff: make binary! 10 parse states [ some [ 'DragOut (either menu? [st/1: #"1"] [st/5: #"1"]) | 'DragOver (either menu? [st/2: #"1"] [st/4: #"1"]) | 'ReleaseOutside (if not menu? [st/3: #"1"]) | 'Release (st/6: #"1") | 'Press (st/7: #"1") | 'RollOut (st/8: #"1") | 'RollOver (st/9: #"1") | 'key set v [char! | string!] ( if string? v [v: v/1] key: next enbase/base to binary! v 2 ) ] to end ] if not empty? st [ insert buff join compile-actions actions #{00} insert buff head reverse load rejoin ["2#{" key st "}"] insert buff either i = length? tmp [#{0000}] [ int-to-ui16 (length? buff) + 2 ] insert tail bin buff ] ] action-bin: copy old-act-bin ] ins form-tag 34 bin ] ) | ['Actions | 'DoAction | 'DoActions] set arg1 [block! | binary! | file! | url!] ( if any [file? arg1 url? arg1] [arg1: read/binary arg1] either binary? arg1 [ insert tail action-bin arg1 ] [insert tail action-bin compile-actions arg1] ) | ['InitAction | 'InitActions | 'DoInitAction] set arg1 [word! | integer!] set arg2 [block! | binary!] ( doInitAction arg1 arg2 ) | 'Class (mv2: mv3: none) opt ['extends set mv2 word!] set mv1 block! opt ['with set mv3 block!] ( create-class mv1 mv2 mv3 ) | 'Extends (mv3: none) set mv2 word! set mv1 block! opt ['with set mv3 block!] ( create-class mv1 mv2 mv3 ) | ['Actions3 | 'DoAction3 | 'DoActions3] set arg1 [file! | url!] ( use [fileParts name ext] [ fileParts: split-path arg1 set [name ext] parse last fileParts "." if ext = "as" [ call/wait rejoin [ "java -jar " to-local-file rswf-root-dir/bin/asc.jar " -optimize " to-local-file arg1 ] ] if exists? arg1: to-file rejoin [name ".abc"] [ probe arg1: read/binary arg1 ins form-tag 82 rejoin [ int-to-ui32 10 "frame1" #{00} arg1 ] ins form-tag 76 rejoin [int-to-ui32 10 name #{00}] ] ] ) | 'stop set arg1 opt ['end] ( insert tail action-bin #{07} if arg1 = 'end [ showFrame ins #{0000} ] ) | ['sound | 'defineSound] set arg1 [file! | url!] (create-defineSound arg1) | 'sounds set arg1 block! ( foreach file arg1 [ insert set-word-buff to-word rejoin ['snd_ last parse file "/"] create-defineSound file ] ) | ['StartSound | 'play] set arg1 [word! | integer! | string!] set arg2 opt [block!] ( use [info loop] [ if not block? arg2 [arg2: make block! []] info: #{00} if find arg2 'noMultiple [info: info or #{10}] loop: either select arg2 'loop [info: info or #{04} int-to-ui16 select arg2 'loop] [#{}] ins form-tag 15 rejoin [ int-to-ui16 get-id arg1 info loop ] ] ) | 'StopSound set arg1 [word! | integer!] ( ins form-tag 15 join int-to-ui16 get-id arg1 #{20} ) | 'mp3Stream set arg1 [file! | url!] ( use [file] [ either any [ not none? file: get-filepath arg1 ] [ stream: make object! [ type: 'mp3 port: open/direct/binary file MakeHead?: true samplesPerFrame: 0 delay: 0 length: 0 idealFrames: 0 mp3frames: 0 frame: 0 ] ] [ print ["Mp3Stream file or url (" arg1 ") doesn't exists!"] ] ] ) | 'finish 'stream ( while [not none? stream] [showFrame] remove/part skip tail body -2 2 ) | 'video set arg1 [integer! | none] ( ins form-tag 60 rejoin [set-id arg1 #{0000A00078000000}] ) | ['background | 'pozadí | 'fondo | 'SetBackgroundColor] set arg1 [tuple! | issue!] ( if not including [ ins form-tag 9 reduce either tuple? arg1 [to binary! arg1] [issue-to-binary arg1] ] ) | 'Rebol set arg1 [block! | file! | url!] ( if error? tmp: try [do arg1] [probe disarm tmp] ) | ['Include | 'zahrnout | 'obsahuje | 'incluir] set arg1 [file! | url! | block!] ( use [data f] [ if not block? arg1 [arg1: reduce [arg1]] foreach file arg1 [ print ["Including:" file] including: true either any [ not none? f: get-filepath file ] [ if block? data: load/header f [compile next data] ] [ make-warning!/msg none ["Cannot include file:" file] ] including: false ] ] ) | ['require | 'needs | 'vyžaduje | 'požaduje | 'requise] set arg1 [file! | url! | block!] ( use [data f] [ if not block? arg1 [arg1: reduce [arg1]] foreach file arg1 [ if none? find included-files file [ print ["Including:" file] insert included-files file including: true either any [ not none? f: get-filepath file ] [compile next load/header f] [ make-warning!/msg none ["Cannot include file:" file] ] including: false ] ] ] ) | ['Export | 'ExportAssets] set arg1 block! ( ExportAssets arg1 ) | ['Import | 'ImportAssets] set arg1 block! opt ['from] copy arg2 [url! | path! | word! | string! | file!] ( use [bin] [ bin: make binary! 50 arg2: either any [word? arg2/1 path? arg2/1] [mold arg2/1] [to string! arg2/1] append bin rejoin [arg2 #"^@"] if swf-version >= 8 [append bin #{0100}] append bin int-to-ui16 (length? arg1) / 2 foreach [id name] arg1 [ append bin rejoin [set-id/as id name #{00}] ] ins form-tag either swf-version < 8 [57] [71] bin ] ) | 'import-swf set arg1 [file! | url!] set arg2 ['no 'end | none] ( use [tmp] [ tmp: import-swf get-filepath arg1 used-ids ins tmp/1 last-depth: tmp/2 probe tmp/3 append names-ids-table tmp/3 ] if not none? arg2 [remove/part skip tail body -2 2] ) | ['label | 'FrameLabel] set arg1 [string! | word! | lit-word!] ( ins form-tag 43 rejoin [#{} arg1 #{00}] ) | set arg1 set-word! ( insert set-word-buff arg1: to word! arg1 if find names-ids-table arg1 [ make-warning!/msg none reform ["Reusing word: " arg1] ] ) | set arg1 get-word! ( either all [ not none? set-word not none? tmp: select names-ids-table to-word arg1 ] [do-set-word tmp] [ make-warning! arg1 ] ) | 'comment set arg any-type! | ['SWFtag | 'prepared] set arg1 integer! set arg2 binary! ( ins form-tag arg1 arg2 ) | 'MetaData set arg1 [string! | block!] ( ins form-metadata arg1 ) | 'FileAttributes set arg1 [binary! | integer!] ( ins form-tag 69 either binary? [copy/part arg1 4] [int-to-ui32 arg1] ) | ['UseNetwork | 'network 'privileges | 'local-with-networking | 'allow 'networking] set arg1 ['off | 'false | 'on | 'off | none] ( ins form-tag 69 either find [off false] arg1 [#{00000000}] [#{01000000}] ) | 'ScriptLimits set arg1 integer! set arg2 integer! ( ins form-tag 65 join int-to-ui16 (max 1 min 65535 arg1) int-to-ui16 (max 1 min 65535 arg2) ) | 'SerialNumber set arg1 opt [binary! | none] ( ins form-tag 41 either none? arg1 [#{01000000000000000200965F0200000000006B68088212010000}] [copy/part arg1 26] ) | 'animation set arg1 block! ( use [i fr-pos to-pos frms step-x step-y pos positions] [ parse/all arg1 [any [ 'move set arg1 [word! | lit-word! | integer!] opt 'from set fr-pos pair! opt 'to set to-pos pair! opt 'in set frms integer! opt 'frames ( step-x: (to-pos/x - fr-pos/x) / frms step-y: (to-pos/y - fr-pos/y) / frms positions: make block! frms pos: make block! reduce [fr-pos/x fr-pos/y] insert positions 20 * fr-pos repeat i frms [ pos/1: pos/1 + step-x pos/2: pos/2 + step-y insert tail positions to pair! reduce [ to integer! 20 * pos/1 to integer! 20 * pos/2 ] ] insert/only animations reduce [arg1 positions] ) ]] ] ) | arg1: any-type! (make-warning! arg1) ] to end ] set-word: func [] [ return current-set-word: either empty? set-word-buff [none] [first set-word-buff] ] init: does [ exported-assets: make block! 20 twips?: false swf-framerate: 12 including: false included-files: make block! 5 body: make binary! 10000 animations: make block! 10 action-bin: make binary! 1000 action-bin-buff: make block! 1000 sprite-recursion-buff: make block! 10 max-bits: 0 set-word-buff: make block! 30 current-set-word: none last-id: none last-depth: 0 used-ids: make block! 50 stream: none names-ids-table: make block! 100 placed-images: make block! 100 placed-objects: make block! 100 recycle true ] string-replace-pairs: none init rename-font: func [font-tag [binary!] newName [string!] /local tmp] [ if 255 < length? newName [clear skip newName 255] font-tag: skip font-tag 2 tmp: first font-tag change font-tag int-to-ui8 length? newName change/part next font-tag newName tmp head font-tag ] to-twips: func [v [number! pair!]] [ if not twips? [v: v * 20] either pair? v [v] [to integer! v] ] issue-to-binary: func [clr] [debase/base clr 16] issue-to-decimal: func [i [issue!] /local e d] [ i: head reverse issue-to-binary i e: 0 d: 0 forall i [ d: d + (i/1 * (2 ** e)) e: e + 8 ] d ] tuple-to-decimal: func [t [tuple!] /local e d] [ t: head reverse as-binary t e: 0 d: 0 forall t [ d: d + (t/1 * (2 ** e)) e: e + 8 ] d ] load-img: func [file id /alpha /size sz /key kcolor /local tmp bin x y type ext bll-file] [ file: copy file ext: last parse file "." bin: make binary! 10000 file: get-filepath file either find ["jpg" "jpeg"] ext [ either exists? file [insert bin read/binary file] [ print ["Cannot find the image file" file "!!"] ] if not empty? bin [ 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] ] ] [ 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 either alpha [ img-to-bll-alpha 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 as-binary x bin-to-int as-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 [ make-warning!/msg none ["Invalid get-id: " mold char] id: last-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 tail used-ids id] either as [ do-set-word/as id id-word ] [do-set-word id] last-id: id int-to-ui16 id ] 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 local-file local-dir host ] [ return case [ any [ exists? f: file (f false) exists? f: rswf-root-dir/:file (f false) exists? f: rswf-project-dir/:file (f false) exists? f: rswf-root-dir/includes/:file (f false) exists? f: rswf-root-dir/fonts/:file (f false) exists? f: rswf-root-dir/bitmaps/:file (f false) ] [f] all [ use-web-includes? (print ["Looking for: " rswf-web-url/:file] true) exists? f: rswf-web-url/:file url? f ] [ print ["Downloading from web:" f] local-dir: join rswf-root-dir %downloaded/ if not exists? local-dir [ make-dir/deep local-dir ] parse form f [thru "//" copy host thru "/" copy local-file to end] replace host ":" "_atport_" local-file: to-file rejoin [local-dir host local-file] read-thru/to f local-file local-file ] true [file] ] ] utf8-encode: func [ "Encodes the string data to UTF-8" str [any-string!] "string to encode" /local c ] [ utf-8/encode-2 ucs2/encode 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!]] [debase/base byte-align bits 2] 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] ] [ 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] ] comment { ;is this function used? 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: :int-to-ui16 bits-needed: func [ {Counts the less number of bits needed to hold the integer} i [integer!] ] [ either i = 0 [0] [1 + to integer! log-2 abs i] ] 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} /local b b2 l bits sb ] [ ints: reduce ints max-bits: 0 bits: make block! length? ints foreach i ints [ 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 ["00"] ["11"]] [back b] 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 [either x = 0 ["0"] [first ints-to-sbs to block! x] int-to-bits y 16] if all [x = 0 i < 0] [fb/1: #"1"] fb ] form-tag: func [ "Creates the SWF-TAG" id [integer!] "Tag ID" data [binary!] "Tag data block" /local len ] [ either any [ 62 < len: length? data not none? find [2 20 34 36 37 48] id ] [ rejoin [ int-to-ui16 (63 or (id * 64)) int-to-ui32 len data ] ] [ rejoin [ int-to-ui16 (len or (id * 64)) data ] ] ] form-metadata: func [data [string! block!] /local metadata] [ metadata: either block? data [ metadata: make string! 500 foreach [tag val] data [ tag: lowercase to-string tag append metadata rejoin ["" val ""] ] rejoin [ {} {} metadata "" ] ] [data] form-tag 77 join utf8-encode metadata #{00} ] showFrame: func [/local] [ foreach animation animations [ use [bin flags m a] [ bin: make binary! 40 flags: make string! "00000001" 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 ] ] 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 [ close stream/port stream: none ] [ create-soundStreamBlock ] ] if not empty? action-bin [ ins form-tag 12 join action-bin #{00} clear action-bin ] 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 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 ] insert tail action-bin either binary? val [val] [compile-actions val] ins form-tag 59 rejoin [ either binary? id [id] [int-to-ui16 get-id id] action-bin #{00} ] clear action-bin ] ExportAssets: func [assets [block!] /local bin] [ bin: make binary! 10 insert bin int-to-ui16 (length? assets) / 2 foreach [id name] assets [ name: either utf8-encode? [utf8-encode name] [name] either find exported-assets name [ make-warning!/msg none reform ["Reusing assets: " name] ] [insert tail exported-assets name] append bin rejoin [int-to-ui16 get-id id name #{00}] ] ins form-tag 56 bin ] create-class: func [definition [block!] extends [word! none!] with [block! none!] /local name id] [ name: first set-word-buff id: form name ins form-tag 39 rejoin [set-id none #{010040000000}] ExportAssets reduce [name id] code: compose/only [ (to-set-word name) (either none? extends ['Class] ['Extends]) (any [extends ()]) (definition) Object.registerClass (to-paren reduce [id name]) ] if block? with [append code with] doInitAction name code ] compile: func [data [block! string!] /rules rul] [ if string? data [data: load data] parse data either rules [rul] [tag-rules] ] create-header: func [version size rate frames] [ rejoin [ #{465753} int-to-ui8 version #{00000000} create-rect/bin 0x0 size * 20 #{00} int-to-ui8 rate int-to-ui16 frames ] ] set 'create-swf func [ size [pair!] "Size of the flash file in pixels!" content [block! binary!] /rate r /version v /compressed compressed? /metadata mtd [block!] /local header swf tmp ] [ init swf: make binary! 10000 swf-version: acompiler/swf-version: either version [v] [6] swf-framerate: either rate [r] [12] if not metadata [ mtd: [ title: "Rebol/Flash dialect made file" publisher: "David 'Oldes' Oliva" ] ] ins form-metadata mtd either binary? content [ append body content ] [ compile content ] either compressed? [ tmp: rejoin [ create-rect/bin 0x0 size * 20 #{00} int-to-ui8 swf-framerate int-to-ui16 frames body ] swf: rejoin [ #{435753} int-to-ui8 swf-version int-to-ui32 8 + length? tmp compress tmp ] ] [ header: create-header swf-version size swf-framerate frames swf: rejoin [header body] 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 [{ Rebol/Flash - } src {
}] ] set 'make-swf func [ {Creates SWF file (MACROMEDIA FLASH) from Rebol/Flash dialect file} 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 ] [ init if url? file [ read-thru/to/update file file: join what-dir last split-path file ] 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 if not integer? swf-version: data/1/type [ if none? swf-version: select [ swf 4 swf5 5 swf6 6 mx 6 mx2004 7 swf7 7 swf8 8 ] swf-version [swf-version: 6] ] acompiler/swf-version: swf-version 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 ] comment "---- end of include %make-swf.r ----" comment { #### Include: %shape.rinc #### Title: "RSWF Shape compiler" #### Author: "" ----} create-shape: func [ arg1 /local changestyle draw-lines rect-min rect-max tmp buff id LineStyles cur-LineSt-id cur-FillSt0-id cur-FillSt0 cur-FillSt1-id shs cur-state i pos w c new x shapeRecords bl at-pos relative? points n r r2 curved? noise ns ns2 tm transf smooth alpha prepare-color default-transformation noise? make-noise were-twips? ] [ shp-size: 100x100 alpha: false smooth: true id: none relative?: false were-twips?: twips? fixed-bounds?: false at-pos: 0x0 curved?: false noise?: false pos: make pair! 0x0 shs: make block! 10 FillStyles: make block! 5 LineStyles: make block! 5 def-LineSt: make block! [0 0.0.0] cur-LineSt: copy def-LineSt cur-FillSt0: none cur-LineSt-id: 0 cur-FillSt0-id: 0 cur-FillSt1-id: 0 rect-max: 0x0 rect-min: 10000x10000 ns: 0x0 ns2: 0x0 cur-state: make string! "00000" shapeRecords: make string! 1000 prepare-color: func [c] [ c: to binary! c c: either alpha [ either 4 > length? c [head insert tail c #{FF}] [copy/part c 4] ] [copy/part c 3] ] prepare-pos: func [pos] [ forall pos [ if not twips? [pos/1: pos/1 * 20] pos/1: either relative? [pos/1 + at-pos] [pos/1] ] head pos ] default-transformation: func [] [ tm: make object! [ scX: 1 scY: 1 sk0: 0 sk1: 0 x: 0 y: 0 c: 0x0 ] ] default-transformation transf: func [p /local lw] [ p: p - tm/c p: to pair! reduce [ round ((p/x * tm/scX) + (p/y * tm/sk1) + tm/x) round ((p/y * tm/scY) + (p/x * tm/sk0) + tm/y) ] p: p + tm/c if not fixed-bounds? [ if error? try [lw: first cur-LineSt] [lw: 20] rect-max: max rect-max (p + lw) rect-min: min rect-min (p - lw) ] return p ] noise: func [arg1 /x] [ arg1: arg1 + either pair? arg1 [ ns2 - random ns ] [either x [ ns2/y - random ns/y ] [ns2/x - random ns/x] ] ] make-noise: func [p] [ forall p [p/1: p/1 + (random ns) - (random ns2)] head p ] changestyle: func [first-pos /local buff] [ buff: copy cur-state first-pos: transf first-pos if pos <> first-pos [ buff/5: #"1" pos: first-pos insert tail buff ints-to-sbs/complete reduce [pos/1 pos/2] 5 ] insert buff #"0" insert shs buff if cur-state/4 = #"1" [cur-state/4 = #"0" insert shs reduce ['f cur-FillSt1-id]] if cur-state/3 = #"1" [cur-state/3 = #"0" insert shs reduce ['f cur-FillSt0-id]] if cur-state/2 = #"1" [cur-state/2 = #"0" insert shs reduce ['l cur-LineSt-id]] ] draw-lines: func [corners /local c LF x new] [ buff: make string! 1000 forall corners [ c: transf corners/1 new: c - pos pos: c if not zero? new [ LF: make string! 2 x: either zero? new/1 [ LF: "01" first ints-to-sbs [new/2] ] [ either zero? new/2 [ LF: "00" first ints-to-sbs [new/1] ] [ LF: "1" rejoin ints-to-sbs [new/1 new/2] ] ] insert tail buff rejoin ["11" int-to-bits max-bits - 2 4 LF x] ] ] insert shs buff ] draw-curves: func [points /local x new1 new2] [ buff: make string! 1000 foreach [c a] points [ c: transf c a: transf a new1: c - pos new2: a - c pos: a x: rejoin ints-to-sbs [new1/1 new1/2 new2/1 new2/2] insert tail buff rejoin ["10" int-to-bits max-bits - 2 4 x] ] insert shs buff ] draw-arc: func [ r startAngle endAngle /center c /local nSegs subangle angle cx cy ax ay ] [ if not pair? r [r: to pair! round r] if not center [c: at-pos] nSegs: 1 + round (7 * (endAngle - startAngle) / 360) subangle: (endAngle - startAngle) / nSegs / 2 angle: startAngle points: make block! [] insert points to pair! reduce [ c/x + round (r/x * sine angle) c/y + round negate (r/y * cosine angle) ] for i 1 nSegs 1 [ angle: angle + subangle cx: r/x * (sine angle) / (cosine subangle) cy: r/y * (cosine angle) / (cosine subangle) insert points to pair! reduce [ c/x + round cx c/y + negate round cy ] angle: angle + subangle ax: r/x * sine angle ay: negate (r/y * cosine angle) insert points to pair! reduce [ c/x + round ax c/y + round ay ] ] points: head reverse points changestyle first points draw-curves next points points ] n-gon: func [n r /local fi x y] [ fi: 360 / n points: make block! n for i 0 360 fi [ x: at-pos/x + round (noise/x r) * sine i y: at-pos/y + round (noise r) * cosine i insert tail points to pair! reduce [x y] ] if noise? [points: make-noise points] change back tail points first points points ] n-star: func [n r1 r2] [ fi: 360 / n corners: make block! n for i 0 360 fi [ i2: i + (fi / 2) insert corners to pair! reduce [ at-pos/x + round r1 * sine i at-pos/y + round r1 * cosine i ] insert corners to pair! reduce [ at-pos/x + round r2 * sine i2 at-pos/y + round r2 * cosine i2 ] ] remove corners if noise? [corners: make-noise corners] if (last corners) <> (first corners) [change back tail corners first corners] corners ] draw-box: func [corners r /roundonly rcorners /local c] [ tmp: prepare-pos corners either none? r [ foreach [b-min b-max] tmp [ either noise? [ c: make-noise reduce [ to pair! reduce [b-max/1 b-min/2] b-max to pair! reduce [b-min/1 b-max/2] b-min ] update-gradient last c first c changestyle last c draw-lines c ] [ update-gradient b-min b-max changestyle b-min draw-lines reduce [ to pair! reduce [b-max/1 b-min/2] b-max to pair! reduce [b-min/1 b-max/2] b-min ] ] ] ] [ if none? rcorners [rcorners: [1 2 3 4]] use [c1 c2 c3 c4 m1 m2 p] [ r: either twips? [r] [r * 20] foreach [c1 c3] tmp [ update-gradient c1 c3 m1: c3/x - c1/x m2: c3/y - c1/y r: either m1 >= m2 [ min m2 / 2 r ] [min m1 / 2 r] c2: to pair! reduce [c3/1 c1/2] c4: to pair! reduce [c1/1 c3/2] m1: r * 1x0 m2: r * 0x1 either none? find rcorners 1 [ changestyle p: c1 ] [changestyle p: c1 + m1] either none? find rcorners 2 [ draw-lines to block! p: c2 ] [ draw-lines to block! p: c2 - m1 draw-arc/center r 0 90 p + m2 ] either none? find rcorners 3 [ draw-lines to block! p: c3 ] [ draw-lines to block! p: c3 - m2 draw-arc/center r 90 180 p - m1 ] either none? find rcorners 4 [ draw-lines to block! p: c4 ] [ draw-lines to block! p: c4 + m1 draw-arc/center r 180 270 p - m2 ] either none? find rcorners 1 [ draw-lines to block! p: c1 ] [ draw-lines to block! p: c1 + m2 draw-arc/center r 270 360 p + m1 ] ] ] ] ] get-fill: func [fill /local i id c type colors center gr-type rot ratios pratios gsz] [ switch first fill [ color [join #{00} prepare-color second fill] bitmap [ type: #{40} rot: 0 sc: 20x20 center: 0x0 id: none parse next fill [ any [ 'clipped (type: #{41}) | 'at set center [pair! | block!] ( if not twips? [ center/1: center/1 * 20 center/2: center/2 * 20 ] ) | 'rotate set rot [block! | number!] ( either block? rot [ forall rot [rot/1: rot/1 * 20] rot: head rot ] [rot: rot * 20] ) | 'scale set sc [block! | number!] ( either block? sc [ forall sc [sc/1: sc/1 * 20] sc: head sc ] [sc: sc * 20] ) | 'id set id [integer! | word!] | tmp: word! ( either find names-ids-table tmp/1 [ id: tmp/1 ] [make-warning! tmp] ) ] ] if not smooth [type: switch type [#{41} [#{43}] #{40} [#{42}]]] fill: rejoin [ type int-to-ui16 get-id id bits-to-bin create-matrix center reduce ['scale sc 'rotate rot] ] ] gradient [ gr-type: #{10} rot: 0 center: none sc: none gsz: none pratios: make block! 8 parse next fill [ any [ 'colors set colors block! | 'center set center pair! | 'radial (gr-type: #{12}) | 'rotate set rot number! | 'size set gsz pair! (gsz: to-twips gsz) | 'ratios set ratios block! ( pratios: copy ratios ) | 'scale set sc [block! | number!] | 'bounds set b-min pair! set b-max pair! ( if not twips? [ b-max: b-max * 20 b-min: b-min * 20 ] bbox: b-max + negate b-min sc: min 1 / (32768 / max abs bbox/x 0.1) 1 / (32768 / max abs bbox/y 0.1) center: b-min + (bbox / 2) ) | any-type! ] to end ] if none? gsz [gsz: shp-size] if none? center [center: gsz / 2] if none? sc [ sc: reduce [1 / (32768 / gsz/x) 1 / (32768 / gsz/y) ] ] if empty? pratios [ i: 0 c: (length? colors) - 1 step: 255 / c repeat i c [ append pratios to integer! (i * step) ] insert pratios 0 ] fill: rejoin [ gr-type bits-to-bin create-matrix center reduce ['scale sc 'rotate rot] int-to-ui8 length? colors ] i: 1 foreach color colors [ repend fill [ int-to-ui8 pratios/:i prepare-color color ] i: i + 1 ] fill ] ] ] set-fill-style: func [fill /left /local new id f] [ either issue? fill [fill: reduce ['color to tuple! issue-to-binary fill]] [ if tuple? fill [fill: reduce ['color fill]] ] new: get-fill copy fill id: either found? f: find FillStyles new [ index? f ] [ append FillStyles new length? FillStyles ] either left [ cur-FillSt1-id: id cur-FillSt1: copy fill ] [ cur-FillSt0-id: id cur-FillSt0: copy fill ] ] set-line-style: func [tmp /local w c new f] [ cur-state/2: #"1" w: c: none new: make block! 2 parse tmp [ any [ 'width set w number! | 'color set c tuple! | 'color set c issue! (c: to tuple! issue-to-binary c) ] to end ] new: reduce [ either none? w [cur-LineSt/1] [to-twips w] either none? c [cur-LineSt/2] [c] ] cur-LineSt-id: either found? f: find LineStyles new [ index? f ] [ append/only LineStyles new length? LineStyles ] cur-LineSt: new ] update-gradient: func [b-min b-max /local bbox sc c f] [ if all [not none? cur-FillSt0 cur-FillSt0/1 = 'gradient none? find cur-FillSt0 'static] [ bbox: b-max + negate b-min sc: reduce [1 / (32768 / max abs bbox/x 0.1) 1 / (32768 / max abs bbox/y 0.1) ] c: b-min + (bbox / 2) either found? f: find/tail cur-FillSt0 'center [ f/1: c ] [ repend cur-FillSt0 ['center c] ] either found? f: find/tail cur-FillSt0 'scale [ f/1: sc ] [ repend cur-FillSt0 ['scale sc] ] set-fill-style cur-FillSt0 ] ] parse arg1 shp-rules: [ any [ 'id set id integer! | 'comment set v string! | opt ['with] 'transparency (alpha: true) | 'Rebol set arg1 block! ( error? try [if error? err: try [do arg1] [probe disarm err]] ) | 'Bounds set rect-min pair! set rect-max pair! ( fixed-bounds?: true shp-size: rect-max + negate rect-min if not twips? [ rect-min: rect-min * 20 rect-max: rect-max * 20 shp-size: 20 * shp-size ] ) | 'noise copy tmp some [pair!] ( error? try [ ns: to-twips tmp/1 ns2: to-twips tmp/2 noise?: true ] ) | 'transform set tmp block! ( use [v] [ default-transformation either not none? v: select tmp 'center [ if number? v [v: reduce [v v]] tm/c: to-twips v if relative? [tm/c: tm/c + at-pos] ] [tm/c: at-pos] if not none? v: select tmp 'rotate [ if number? v [v: reduce [v v]] tm/scx: cosine v/1 tm/scy: cosine v/2 tm/sk0: sine v/1 tm/sk1: negate sine v/2 ] if not none? v: select tmp 'scale [ if number? v [v: reduce [v v]] tm/scx: tm/scx * v/1 tm/scy: tm/scy * v/2 tm/sk0: tm/sk0 * v/1 tm/sk1: tm/sk1 * v/2 ] if not none? v: select tmp 'skew [ v: reduce either number? v [[v v]] [[v/1 v/2]] v: reduce [v/1 / 360 v/2 / 360] tm/sk0: tm/sk0 + v/2 tm/sk1: tm/sk1 + v/1 ] if not none? v: select tmp 'reflect [ v: reduce either number? v [[v v]] [[v/1 v/2]] tm/scx: tm/scx * v/1 tm/scy: tm/scy * v/2 ] if not none? v: select tmp 'move [ v: to-twips v v: reduce either number? v [[v v]] [[v/1 v/2]] tm/x: tm/x + v/1 tm/y: tm/y + v/2 ] ] ) | 'positions ['relative (relative?: true) | 'absolute (relative?: false)] | 'at set at-pos pair! (if not twips? [at-pos: at-pos * 20] tm/c: at-pos relative?: true) | 'units [ 'twips (twips?: on at-pos: at-pos * 20) | 'pixels (twips?: off at-pos: at-pos / 20) ] | 'no [ 'fill ( if cur-FillSt0-id > 0 [ cur-FillSt0-id: 0 cur-state/3: #"1" ] ) | 'edge ( if cur-LineSt-id > 0 [ cur-LineSt-id: 0 cur-state/2: #"1" ] ) | 'noise (ns: ns2: 0x0) | 'transform (default-transformation) ] | 'pen 'none ( if cur-LineSt-id > 0 [ cur-LineSt-id: 0 cur-state/2: #"1" ] ) | ['line-style | 'edge | 'lines] [ set tmp block! (set-line-style tmp) | [ (w: c: none) opt ['width set w number!] opt ['color set c [tuple! | issue!]] (set-line-style compose [width (w) color (c)]) ] ] | 'gradient set tmp [block! | 'static] ( either block? tmp [ cur-state/3: #"1" insert tmp 'gradient set-fill-style tmp ] [ if all [ found? find cur-FillSt0 'gradient none? find cur-FillSt0 'static ] [append cur-FillSt0 'static] ] ) | 'fill 'bitmap set tmp [word! | integer! | block!] ( cur-state/3: #"1" set-fill-style compose [bitmap (tmp)] ) | ['fill-style | 'fill 'color | 'výplň] set tmp [block! | tuple! | issue!] ( cur-state/3: #"1" set-fill-style tmp ) | 'fill-style1 set tmp block! ( cur-state/4: #"1" set-fill-style/left tmp ) | 'smoothing ['on (smooth: true) | 'off (smooth: false)] | 'image set tmp [word! | integer!] ( use [atp id] [ atp: at-pos / 20 id: get-id tmp parse/all x: compose/deep [ fill-style [bitmap id (tmp) at (atp) clipped] no edge box (atp) (atp + 1 + select placed-images id) ] shp-rules ] ) | 'columns set tmp block! ( use [data from blk i w sp ofs] [ ofs: none w: 10 sp: 0 parse tmp [ any [ 'data set data block! | 'from set from word! | 'at set ofs pair! | 'width set w number! | 'space set sp integer! | any-type! ] ] blk: make block! 1 + 2 * length? data insert blk 'box i: 0 switch from [ bottom [ if none? ofs [ofs: shp-size / 20] foreach h data [ repend blk [ to pair! reduce [ofs/x + i ofs/y] to pair! reduce [ofs/x + i: i + w ofs/y - h] ] i: i + sp ] ] left [ if none? ofs [ofs: rect-min / 20] foreach h data [ repend blk [ to pair! reduce [ofs/x i + ofs/y] to pair! reduce [ofs/x + h ofs/y + i: i + w] ] i: i + sp ] ] ] parse blk shp-rules ] ) | ['box | 'rectangle | 'obdélník] (r: r2: none) any ['rounded set r any [integer!] opt 'only set r2 [block! | none]] copy tmp any [pair!] ( if block? tmp [draw-box/roundonly tmp r r2] ) | 'box2 (r: none) any ['rounded set r any [integer!]] copy tmp any [pair!] ( if block? tmp [ use [c p] [ c: make block! 2 * length? tmp forall tmp [ p: tmp/1 / 2 repend c [at-pos - p at-pos + p] ] draw-box c r ] ] ) | ['circle | 'oval] copy tmp any [number! | pair!] ( forall tmp [ c: either twips? [tmp/1] [tmp/1 * 20] update-gradient at-pos - c at-pos + c draw-arc c 0 360 ] ) | 'arc copy tmp any [number!] ( foreach [r stAng enAng] tmp [ draw-arc either twips? [r] [r * 20] stAng enAng draw-lines reduce [at-pos first points] ] ) | 'curved (curved?: true) | 'n-gon set n integer! set r number! ( if not twips? [r: r * 20] tmp: n-gon n r update-gradient at-pos - r at-pos + r changestyle first tmp either curved? [ draw-curves next tmp curved?: false ] [draw-lines next tmp] ) | 'n-star set n integer! set r1 number! set r2 number! ( r1: to-twips r1 r2: to-twips r2 tmp: n-star n r1 r2 r: max r1 r2 update-gradient at-pos - r at-pos + r changestyle first tmp either curved? [ draw-curves next tmp curved?: false ] [draw-lines next tmp] ) | 'g-frame set tmp block! ( use [tw bmi bma w colors c1 c2 c3 c4 i1 i2 i3 i4] [ bmi: to-twips tmp/1 bma: to-twips tmp/2 w: to-twips tmp/3 colors: tmp/4 tw: twips? twips?: on c1: bmi c2: (0x1 * bmi) + (1x0 * bma) c3: bma c4: (1x0 * bmi) + (0x1 * bma) i1: bmi + w i2: c2 + (-1x1 * w) i3: c3 - w i4: c4 + (1x-1 * w) cur-state/3: #"1" set-fill-style compose/deep [ gradient colors [(colors)] bounds (c1) (c4 + (1x0 * w)) ] changestyle c1 draw-lines reduce [i1 i4 c4 c1] cur-state/3: #"1" set-fill-style compose/deep [ gradient colors [(colors)] rotate 90 bounds (c1) (c2 + (0x1 * w)) ] changestyle c1 draw-lines reduce [c2 i2 i1 c1] cur-state/3: #"1" set-fill-style compose/deep [ gradient colors [(colors)] rotate 180 bounds (c2 - (1x0 * w)) (c3) ] changestyle c3 draw-lines reduce [c2 i2 i3 c3] cur-state/3: #"1" set-fill-style compose/deep [ gradient colors [(colors)] rotate 270 bounds (c4 - (0x1 * w)) (c3) ] changestyle c3 draw-lines reduce [i3 i4 c4 c3] twips?: tw ] ) | 'line copy tmp any [pair!] ( if block? tmp [ tmp: prepare-pos tmp changestyle first tmp draw-lines next tmp ] ) | 'curve copy tmp any [pair!] ( if block? tmp [ tmp: prepare-pos tmp changestyle first tmp draw-curves next tmp ] ) | 'cross copy tmp any [pair!] ( if block? tmp [ foreach cr tmp [ if not twips? [cr: cr * 20] cmin: to pair! reduce [cr/x / -2 cr/y / -2] cmax: cmin * -1 if relative? [cmin: at-pos + cmin cmax: at-pos + cmax] changestyle cmin draw-lines to block! cmax changestyle to pair! reduce [cmax/x cmin/y] draw-lines to block! to pair! reduce [cmin/x cmax/y] ] ] ) | 'grid copy tmp any [pair!] ( if block? tmp [ tmp: prepare-pos tmp use [i c1 c2 mi ma sz] [ set [mi ma sz] reduce [tmp/1 tmp/2 tmp/3] if 0 < sz/1 [ i: mi/1 while [i <= ma/1] [ c1: noise to pair! reduce [mi/1 + i 0] c2: noise to pair! reduce [mi/1 + i ma/2] changestyle c1 draw-lines reduce [c1 c2] i: i + sz/1 ] ] if 0 < sz/2 [ i: mi/2 while [i <= ma/2] [ c1: noise to pair! reduce [0 mi/2 + i] c2: noise to pair! reduce [ma/1 mi/2 + i] changestyle c1 draw-lines reduce [c1 c2] i: i + sz/2 ] ] ] ] ) | arg1: any-type! (make-warning! arg1) ] to end ] shp-size: rect-max + negate rect-min buff: make binary! 100 append buff rejoin [ set-id id create-rect/bin rect-min rect-max ] append buff either 255 <= tmp: length? FillStyles [ join #{FF} int-to-ui16 tmp ] [int-to-ui8 tmp] repeat i tmp [repend buff FillStyles/:i] append buff either 255 <= tmp: length? LineStyles [ join #{FF} int-to-ui16 tmp ] [int-to-ui8 tmp] repeat i tmp [ repend buff [ int-to-ui16 first LineStyles/:i prepare-color second LineStyles/:i ] ] append buff debase/base ( join int-to-bits bf: bits-needed length? FillStyles 4 int-to-bits bl: bits-needed length? LineStyles 4 ) 2 parse shs [ any [ set tmp string! (insert shapeRecords tmp) | 'l set tmp integer! (insert shapeRecords int-to-bits tmp bl) | 'f set tmp integer! (insert shapeRecords int-to-bits tmp bf) ] ] ins form-tag either alpha [32] [2] rejoin [ buff debase/base byte-align join shapeRecords "000000" 2 ] twips?: were-twips? ] comment "---- end of include %shape.rinc ----" comment { #### Include: %utils/compress-swf.r #### Title: "SWF compressor" #### Author: "oldes" ----} compress-swf: func [file /local swf-bin version new-swf original-size] [ if not exists? file [ print ["Cannot find file" mold file "!"] return none ] swf-bin: read/binary file original-size: length? swf-bin return either parse/all swf-bin ["FWS" copy version 1 skip to end] [ version: to-integer to-binary version if version < 6 [version: 6] swf-bin: copy skip swf-bin 8 new-swf: rejoin [ #{435753} load rejoin ["#{0" version "}"] int-to-ui32 8 + length? swf-bin compress swf-bin ] either original-size <= length? new-swf [ print ["Compressed file (" file ") is not smaller!"] none ] [new-swf] ] [ print ["File:" mold file "is not an uncompressed SWF file!"] none ] ] comment "---- end of include %utils/compress-swf.r ----" comment { #### Include: %img-to-bll2.rinc #### Title: {Image to BitLossless - Rebol/View version >= 1.2.8 !} #### Author: "oldes" ----} img-to-bll: func [ {Converts any image to Flash bitmap (bitLossless) format} img [file! url! image!] "Image to convert" /alpha transp "If you want to create alpha version" /mask maskimg "Image that contains mask information" /key key-color "If you need some color to be transparent" /local c pix w x szx szy i color colors BitmapPixelData ColorTableRGB f ] [ if key [key-color: to-binary key-color] if not image? img [img: load img] if mask [ if not image? maskimg [maskimg: load maskimg] if maskimg/size <> img/size [ print "Size of the image and its mask must be same!" halt ] ] set [szx szy] reduce [img/size/x img/size/y] colors: make hash! szx * szy w: szx while [(w // 4) > 0] [w: w + 1] w: w - szx BitmapPixelData: make binary! 4 * (szx + w) * szy x: 1 c: 1 pix: szx * szy while [c <= pix] [ color: to-binary img/:c either any [alpha key mask] [ either key [ either find/part color key-color 3 [color: #{00000000}] [change skip color 3 #{FF}] ] [ either alpha [ either not none? transp [ change skip color 3 transp ] [ ] ] [ change skip color 3 to-binary to-char first maskimg/:c ] ] ] [ color: copy/part color 3 ] i: either found? f: find colors color [ index? f ] [ insert tail colors color length? colors ] i: int-to-ui8 (i - 1) insert tail BitmapPixelData i either x = szx [ insert/dup tail BitmapPixelData i w x: 1 ] [x: x + 1] c: c + 1 ] ColorTableRGB: rejoin to-block colors rejoin [ int-to-ui8 3 int-to-ui16 szx int-to-ui16 szy int-to-ui8 (length? colors) - 1 head remove/part tail compress join ColorTableRGB BitmapPixelData -4 ] ] img-to-bll-alpha: func [ {Converts any image to Flash bitmap (bitLossless) alpha format} img [image! file! url! string!] "Image to convert" /local szx szy RGBA pixel ] [ if not image? img [img: load either string? img [to-rebol-file img] [img]] set [szx szy] reduce [img/size/x img/size/y] RGBA: make binary! (szx * szy * 4) while [not tail? img] [ pixel: to-binary first img insert tail RGBA complement copy/part skip pixel 3 1 insert tail RGBA copy/part pixel 3 img: next img ] rejoin [ int-to-ui8 5 int-to-ui16 szx int-to-ui16 szy head remove/part tail compress RGBA -4 ] ] comment "---- end of include %img-to-bll2.rinc ----" ]