DZone Snippets: dialect code

SET+

gregg.irwin (Gregg Irwin) — Mon, 29 May 2006 22:35:02 GMT



    set+: func [ ; Inspired by Erlang's list model.

        "Like SET, but words block is dialected."

        words  [any-block!] "Word after | gets remainder of series."

        series [series!]

        /local word= rule=

    ][

        word=: [set word word!]

        rule=: [

            any [

                '| word= (set word series) to end

                | word= (

                    set word pick series 1

                    series: next series

                )

            ]

        ]

        parse words rule=

    ]

    ;set+ [a | rest] [1 2 3 4 5]

    ;set+ [a b | rest] [1 2 3 4 5]

    ;set+ [a b c] [1 2]

CAST function - Convert a value referenced by a word to a new datatype. Dialected

gregg.irwin (Gregg Irwin) — Thu, 25 May 2006 03:09:06 GMT



    cast: func [ ; convert coerce

        "Convert a value referenced by a word to a new datatype."

        input [block!] "A word, and the target datatype."

        /local words type val

    ] [

        parse input [

            some [

                copy words to 'to skip set type any-type! (

                    ;while [pos: find words 'and] [remove pos]

                    remove-each word words [word = 'and]

                    foreach word words [

                        val: get/any word

                        set/any word to either word? type [get type] [type] val

                    ]

                )

            ]

        ]

    ]

    comment {

        a: "A-0001"

        b: #B002

        c: 300

        d:

`e: 'test cast [a to issue!] print mold :a cast [b to tag!] print mold :b cast [c to decimal!] print mold :c cast [a b c to string!] print remold [:a :b :c] cast [a b and c to issue!] print remold [:a :b :c] cast [ a b and c to tag! and d and e to issue! ] print remold [:a :b :c :d :e] cast [a b c to d e to "x"] print remold [:a :b :c :d :e] }`

file-size-comparison-ctx - find files matching size criteria; dialected interface

gregg.irwin (Gregg Irwin) — Tue, 23 May 2006 21:43:57 GMT

// description of your code here



file-size-comparison-ctx: context [

    =negate-op?: none

    =or-equal?: none

    =op: none

    =size: 0

    =size-mul: 1

    =parse-end-mark: none



    make-lit-word: func [val] [to lit-word! :val]

    lit-lesser: make-lit-word "<"

    lit-greater: make-lit-word ">"

    lit-lesser-or-equal: make-lit-word "<="

    lit-greater-or-equal: make-lit-word ">="



    size=: [

        (=size-mul: 1)

        set =size number!

        opt [

            'bytes ; no change to size-mul

            | ['kilobytes | 'KB] (=size-mul: 1024.0)

            | ['megabytes | 'MB] (=size-mul: 1048576.0)

            | ['gigabytes | 'GB] (=size-mul: 1073741824.0)

        ]

        (=size: =size * =size-mul)

    ]

    word-comparison=: [

        [

            ['more | 'bigger | 'larger | 'greater] (=op: 'greater)

            | ['less | 'smaller] (=op: 'lesser)

        ] 'than

        opt ['or 'equal 'to (=or-equal?: true)]

    ]

    lit-comparison=: [

        lit-lesser             (=or-equal?: false  =op: 'lesser)

        | lit-greater          (=or-equal?: false  =op: 'greater)

        | lit-lesser-or-equal  (=or-equal?: true   =op: 'lesser)

        | lit-greater-or-equal (=or-equal?: true   =op: 'greater)

    ]

    rules=: [

        (=negate-op?: =or-equal?: =op: =parse-end-mark: none)

        opt 'if opt ['size | size?]

        opt [['no | 'not] (=negate-op?: true)]

        [word-comparison= | lit-comparison=]

        (if =negate-op? [=op: pick [greater lesser] =op = 'lesser])

        (=op: to word! rejoin [=op either =or-equal? ['-or-equal] [""] '?])

        size=

        =parse-end-mark:

    ]



    set 'size-comparison-cmd? func [input [block!]] [

        parse input rules=

        return =parse-end-mark

    ]



    set 'make-file-size-comparison-func func [spec] [

        parse spec rules=

        either =parse-end-mark [

            func [file] reduce [=op 'size? 'file =size]

        ] [none]

    ]



    set 'files-matching-size-spec func [

        files [block!]

        spec [block!]

    ][

        if match?: make-file-size-comparison-func spec [

            collect 'keep [

                foreach file files [if match? file [keep: file]]

            ]

        ]

    ]

]

;foreach file files-matching-size-spec read %. [>= 64 kb] [print [file size? file]]

file-date-comparison-ctx - find files matching date criteria; dialected interface

gregg.irwin (Gregg Irwin) — Tue, 23 May 2006 21:42:36 GMT

// description of your code here



file-date-comparison-ctx: context [

    =negate-op?: none

    =or-equal?: none

    =op: none

    =parse-end-mark: none

    =attr: 'modification-date

    =date: none



    make-lit-word: func [val] [to lit-word! :val]

    lit-equal: make-lit-word "="

    lit-lesser: make-lit-word "<"

    lit-greater: make-lit-word ">"

    lit-lesser-or-equal: make-lit-word "<="

    lit-greater-or-equal: make-lit-word ">="



    attr=: [

        ['changed | 'modified | 'upated | 'modification-date]

        | ['created | 'creation-date | 'create-date] (=attr: 'creation-date)

        | ['accessed | 'access-date] (=attr: 'access-date)

    ]

    date=: [

        [

            set =date date!

            | set =date file!      (=date: get-modes =date =attr)

            | 'yesterday (=date: now/date - 1)

            | 'today     (=date: now/date)

            | 'tomorrow  (=date: now/date + 1)

        ]

    ]

    word-comparison=: [

        [

            ['after | 'since | 'newer 'than] (=op: 'greater)

            | ['before | 'older 'than] (=op: 'lesser)

        ]

        opt ['or 'equal 'to (=or-equal?: true)]

    ]

    lit-comparison=: [

        lit-equal              (=or-equal?: false  =op: 'equal)

        | lit-lesser           (=or-equal?: false  =op: 'lesser)

        | lit-greater          (=or-equal?: false  =op: 'greater)

        | lit-lesser-or-equal  (=or-equal?: true   =op: 'lesser)

        | lit-greater-or-equal (=or-equal?: true   =op: 'greater)

    ]

    rules=: [

        (

            =negate-op?: =or-equal?: =op: =parse-end-mark: =date: none

            =attr: 'modification-date

        )

        opt 'if opt ['date | 'date?]

        opt [['no | 'not] (=negate-op?: true)]

        opt ['date | 'date?]

        opt attr=

        [word-comparison= | lit-comparison=]

        (if =negate-op? [=op: pick [greater lesser] =op = 'lesser])

        (=op: to word! rejoin [=op either =or-equal? ['-or-equal] [""] '?])

        date=

        =parse-end-mark:

    ]



    set 'date-comparison-cmd? func [input [block!]] [

        parse input rules=

        return =parse-end-mark

    ]



    set 'make-file-date-comparison-func func [spec] [

        parse spec rules=

        either =parse-end-mark [

            func [file] reduce [=op  'get-modes 'file to lit-word! =attr  =date]

        ] [none]

    ]



    set 'files-matching-date-spec func [

        files [block!]

        spec [block!]

    ][

        if match?: make-file-date-comparison-func spec [

            collect 'keep [

                foreach file files [if match? file [keep: file]]

            ]

        ]

    ]

]

;foreach file files-matching-date-spec read %. [accessed after 1-jan-2006] [print [file modified? file]]

;foreach file files-matching-date-spec read %. [date < 1-jan-2006] [print [file modified? file]]

Parse multiple, independently fixed length, integer values from a string

gregg.irwin (Gregg Irwin) — Thu, 16 Feb 2006 00:28:44 GMT



parse-int-values: func [

    "Parses and returns integer values, each  chars long in a string."

    input [any-string!]

    spec [block!] "Dialected block of commands: , skip , done, char, or string"

    /local

        gen'd-rules ; generated rules

        result      ; what we return to the caller

        emit emit-data-rule emit-skip-rule emit-literal-rule emit-data

        digit= n= literal=

        int-rule= skip-rule= literal-rule= done= build-rule=

        data-rule skip-rule

][

    ; This is where we put the rules we build; our gernated parse rules.

    gen'd-rules: copy []

    ; This is where we put the integer results

    result: copy []



    ; helper functions

    emit: func [rule n] [append gen'd-rules replace copy rule 'n n]

    emit-data-rule: func [n] [emit data-rule n]

    emit-skip-rule: func [n] [emit skip-rule n]

    emit-literal-rule: func [value] [append gen'd-rules value]

    emit-data: does [append result to integer! =chars]



    ; Rule templates; used to generate rules

    ;data-rule: [copy =chars n digit= (append result to integer! =chars)]

    data-rule: [copy =chars n digit= (emit-data)]

    skip-rule: [n skip]



    ; helper parse rules

	digit=: charset [#"0" - #"9"]

    n=: [set n integer!]

    literal=: [set lit-val [char! | any-string!]]



    ; Rule generation helper parse rules

    int-rule=: [n= (emit-data-rule n)]

    skip-rule=: ['skip n= (emit-skip-rule n)]

    literal-rule=: [literal= (emit-literal-rule lit-val)]

    done=: ['done (append gen'd-rules [to end])]



    ; This generates the parse rules used against the input

    build-rule=: [some [skip-rule= | int-rule= | literal-rule=] opt done=]



    ; We parse the spec they give us, and use that to generate the

    ; parse rules used against the actual input. If the spec parse

    ; fails, we return none (maybe we should throw an error though);

    ; if the data parse fails, we return false; otherwise they get

    ; back a block of integers. Have to decide what to do if they

    ; give us negative numbers as well.

    either parse spec build-rule= [

        either parse input gen'd-rules [result] [false]

    ] [none]

]

comment {

    test: func [val spec] [print mold parse-int-values val spec]

    test "20060228T190000" [4 2 2 skip 1 2 2 2]

    test "20060228T190000" [4 2 2 #"T" 2 2 2]

    test "20060228T190000Z" [4 2 2 #"T" 2 2 2 #"Z"]

    test "20060228T190000Z" [4 2 2 #"T" 2 2 2 done]

    test %2006021509450004.jpg [4 2 2 2 2 4 skip 4]

    test %2006021509450004.jpg [4 2 2 2 2 4 done]

    ; tests that *should* fail

    ; Bad spec

    test "20060228T190000Z" [4 2 x #"T" 2 2 2]

    test "20060228T190000Z" [4 2 2 #"T" 2.5 2 2]

    ; Bad input

    test "20060228T190000Z" [4 2 2 #"T" 2 2 2]

    test "2000228T190000Z" [4 2 2 #"T" 2 2 2 done]

    test "20060228x190000Z" [4 2 2 #"T" 2 2 2 done]

}

Localizing a dialect with ALIAS

gregg.irwin (Gregg Irwin) — Thu, 19 Jan 2006 03:17:36 GMT



; Localizing a dialect; obviously just a basic idea.



alias 'who   "welche"

alias 'where "wo"

alias 'when  "wann"



rule: [

    some [

        'who   set persons [word! | block!] |

        'where set place string! |

        'when  set time time!

    ]

    to end

]



time: place: persons: none

parse [

    who   Fred

    where "Your house"

    when  9:30

] rule

print [time place persons]



time: place: persons: none

parse [

    welche Karl

    wo     "Euer Haus"

    wann   11:30

] rule

print [time place persons]

DEFINE dialect

gregg.irwin (Gregg Irwin) — Fri, 13 Jan 2006 04:20:44 GMT



REBOL [

    Title:   "#define dialected function"

    File:    %define-dialect.r

    Author:  "Gregg Irwin"

    Version: 0.0.1

    Date:    23-sep-2003

    Purpose: {

        Make it easier to map C #define statements. Eliminates

        the need to manually call datatype conversion functions 

        for each item.

    }

    Comment: {

        The block you pass to the function is a dialect. In the

        dialect you can specify word-value pairs and functions

        used to map different types of values as they are

        processed.



        MAP is used to tell the processor what function to call

        when it encounters a particular datatype value. The

        function specified should take a single value.



            'map datatype function-name



            ; call to-integer when a binary! value is found.

            [map binary! to-integer]



        Other than that, just specify a word followed by a value.

        The resulting block will contain set-word! values for

        each word, followed by its value - which may have been

        converted by a function that was mapped to its original

        datatype.

    }

    Example: {

        do define [

            map binary! to-integer

            map issue!  to-integer



            my-name "Gregg"

            mapped-binary  #{00000001}

            mapped-issue   #000fffff

        ]

        print [my-name mapped-binary mapped-issue]

    }

    library: [

        level:    'intermediate

        platform: 'all

        type:     [function]

        domain:   [dialect parse external-library]

        tested-under: [view 1.2.8.3.1 on W2K]

        support:  none

        license:  none

        see-also: none

    ]

]





define: func [

    block [any-block!]

    /local type fn word val result map

] [

    result: make block length? block

    map: copy []

    either parse block [

        some [

            'map set type word! set fn word! (

                type: do type

                either word: find/skip map type 2 [

                    change next word get fn

                ][

                    append map reduce [type get fn]

                ]

            )

            | set word any-word! set val any-type! (

                append result reduce [

                    to set-word! word

                    either fn: select map type? val [fn val][val]

                ]

            )

        ]

        to end

    ] [result][none]

]





comment [ ; test examples

    print mold defs: define [

        map binary!  to-integer

        map issue!   to-integer



        PFD_DOUBLEBUFFER  #{00000001}

        PFD_STEREO  #{00000002}

        PFD_DRAW_TO_WINDOW  #00000004

        GL_ALL_ATTRIB_BITS  #000fffff

    ]

    do defs

    print [

        PFD_DOUBLEBUFFER

        PFD_STEREO

        PFD_DRAW_TO_WINDOW

        GL_ALL_ATTRIB_BITS

    ]



    halt

]

Library interface dialect

gregg.irwin (Gregg Irwin) — Fri, 13 Jan 2006 04:11:40 GMT



REBOL [

    Title:  "Library Interface Dialect"

    File:   %lib-dialect.r

    Author: "Gregg Irwin"

    Purpose: {

        Allow for a more concise way to define library routine 

        interfaces.

    }

]



lib-dialect-ctx: context [

;     lib-ctx: make object! [file: lib: none free: does [free lib]]

;     lib-spec: none



    lib: none

    def-rtn-type: none



    name-mods: copy []

    mod-name: func [name] [do join name-mods name]



    ; dump/trace option to show generated code?



    ;has-rtn-type?: does [all [rtn-type  'none <> rtn-type]]

    ; lib is a global word reference in this func.

    make-dll-func: func [reb-name spec rtn-type name] [

        spec: copy any [spec []]

        if all [rtn-type  'none <> rtn-type] [

            append spec compose/deep [return: [(rtn-type)]]

        ]

        ;print ['make-dll-func reb-name mold spec rtn-type mold  mod-name any [name  form reb-name]]

        set reb-name make routine! spec lib  mod-name any [name  form reb-name]

    ]



    data-type: [

        'none | 'char | 'short | 'long | 'integer! | 'string! | 'decimal!

        ; TBD add struct support ?

    ]



    func-decl: [

        (spec: name: none  rtn-type: def-rtn-type)

        set reb-name word!          ;(print reb-name)

        any [

              [set spec block!]     ;(print mold spec)

            | [opt ['returns | 'as] set rtn-type data-type]  ;(print rtn-type)

            | [opt 'calls set name string!]    ;(print name)

        ]

        (make-dll-func reb-name spec rtn-type name)

    ]



    ; You can use this multiple times, e.g. grouping functions by return

    ; type and using it before each group.

    set-def-rtn-type: [

        opt 'set ['def-rtn-type | 'default-return-type]

        set def-rtn-type data-type

    ]



    rules: [

        ['lib | 'library] set file file! (lib: load/library file) ;append lib-spec compose [file: (file)]

        opt [

            ['modify-import-names | 'mod-imports] set name-mods block!

        ]

        any [set-def-rtn-type | func-decl]

    ]



    set 'make-routines func [spec [any-block!]] [

        clear name-mods

        parse spec rules

    ]



;     set 'make-library-interface func [spec] [

;         lib-spec: copy []

;         clear name-mods

;         parse spec rules

;     ]



]

excerpt function

gregg.irwin (Gregg Irwin) — Tue, 10 Jan 2006 06:27:53 GMT



    ;-- collect-based EXCERPT ----------------------------------

    ; Could also change EXTRACT to accept a block value for WIDTH

    ; (renamed to, e.g., SPEC).

    ; The dialect allows you to use commas in the block, but how they

    ; are interpreted is not how you might think. Coming after a number,

    ; they are a valid lexical form, but they denote a decimal! rather

    ; than being seen as a separator, which means you can't use them too

    ; flexibly.

    excerpt: func [

        {Returns the specified items and/or ranges from the series.}

        series  [series!]

        offsets [block!] {Offsets of the items to extract; dialected.}

        /only "return sub-block ranges as blocks"

        /local

            emit-range rules

            from* to* index*    ; parse vars

    ][

        ; always uses ONLY right now; it's a prototype.

        collect/only val [

            emit-range: func [start end] [

                start: to integer! start

                if number? end [end: to integer! end - start + 1]

                val: either end = 'end [copy at series start][

                    copy/part at series start end

                ]

            ]

            rules: [

                some [

                    opt 'from set from* number! 'to set to* number! (

                        emit-range from* to*

                    )

                  | opt 'from set from* number! 'to 'end (emit-range from* 'end)

                  | 'to set to* number! (emit-range 1 to*)

                  | set index* number!  (val: pick series index*)

                  | into rules

                ]

            ]

            parse offsets rules

        ]

    ]

    comment {

        b: [1 2 3 4 5 6 7 8 9 10 11 12 13 14]

        excerpt b [1 3 5]

        excerpt b [1 3 to 6 8]

        excerpt/only b [1, 3 to 6, 8]

        excerpt b [1 [5 to 7] 8]

        excerpt/only b [1 (from 5 to 7) 8]

        excerpt b [(to 2) [4 to 6] 8, 10, from 12 to end]

        excerpt/only b [to 2, 4 to 6, 8, 10, (12 to end)]

        ; Can't use a comma after 'end

        excerpt/only b [to 2 to 6 8 10 to end 12 to end]

        excerpt/only b [to 2, to 6, 8 [10 to end] 12 to end]

        excerpt/only trim {

            REBOL is my favorite language

        } [

            to 5, 10 to 11, 13, 14, 15, 22 to end

        ]

        excerpt/only to binary! {REBOL is my favorite language} [

            to 5, 10 to 11, 13, 14, 15, 22 to end

        ]

    }

collect function

gregg.irwin (Gregg Irwin) — Tue, 10 Jan 2006 06:25:51 GMT



    ; What about extending this to work on string values?

    collect: func [  ; a.k.a. gather ?

        [throw]

        {Collects block evaluations.}

        'word "Word to collect (as a set-word! in the block)"

        block [any-block!] "Block to evaluate"

        /into dest [series!] "Where to append results"

        /only "Insert series results as series"

        ;/debug

        /local code marker at-marker? marker* mark replace-marker rules

    ] [

        block: copy/deep block

        dest: any [dest make block! []]

        ; "not only" forces the result to logic!, for use with PICK.

        ; insert+tail pays off here over append.

        ;code: reduce [pick [insert insert/only] not only 'tail 'dest]

        ; FIRST BACK allows pass-thru assignment of value. Speed hit though.

        ;code: reduce ['first 'back pick [insert insert/only] not only 'tail 'dest]

        code: compose [first back (pick [insert insert/only] not only) tail dest]

        marker: to set-word! word

        at-marker?: does [mark/1 = marker]

        ; We have to use change/part since we want to replace only one

        ; item (the marker), but our code is more than one item long.

        replace-marker: does [change/part mark code 1]

        ;if debug [probe code probe marker]

        marker*: [mark: set-word! (if at-marker? [replace-marker])]

        parse block rules: [any [marker* | into rules | skip]]

        ;if debug [probe block]

        do block

        head :dest

    ]



    comment {

        ;collect/debug zz [repeat n 10 [zz: n * 100]]

        collect zz []

        collect zz [repeat i 10 [if (zz: i) >= 3 [break]]]

        collect zz [repeat i 10 [zz: i  if i >= 3 [break]]]

        collect zz [repeat i 10 [either i <= 3 [zz: i][break]]]

        dest: copy []

        collect/into zz [repeat n 10 [zz: n * 100]] dest

        collect zz [for i 1 10 2 [zz: i * 10]]

        collect zz [for x 1 10 1 [zz: x]]

        collect zz [foreach [a b] [1 2 3 4] [zz: a + b]]

        collect zz [foreach w [a b c d] [zz: w]]

        collect zz [repeat e [a b c %.txt] [zz: file? e]]

        iota: func [n [integer!]][collect zz [repeat i n [zz: i]]]

        iota 10

        collect zz [foreach x first system [zz: to-set-word x]]

        x: first system

        collect zz [forall x [zz: length? x]]

        x: first system

        collect zz [forskip x 2 [zz: length? x]]

        collect zz [forskip x 2 [zz: (length? x) / 0]]

        collect/only zz [foreach [a b] [1 2 3 4] [zz: a zz: b zz: reduce [a b a + b]]]

        collect/only zz [

            foreach [a b] [1 2 3 4] [

                zz: a zz: b zz: reduce [a b a + b]

                foreach n reduce [a b a + b] [zz: n * 10]

            ]

        ]



        dest: copy ""

        collect/into zz [repeat n 10 [zz: n * 100 zz: " "]] dest



        dest: copy []

        collect/into zz [

            foreach [num blk] [1 [a b c] 2 [d e f] 3 [g h i]] [

                zz: num

                collect/only/into yy [

                    zz: blk

                    foreach word blk [zz: yy: num  yy: word]

                    yy: blk

                ] dest

            ]

        ] dest



    }