REBOL [
	Title: "Custom datatypes"
	Author: "Gabriele Santilli"
    EMail: giesse@rebol.it
	File: %custom-types.r
    Purpose: {
        Allows the programmer to define custom REBOL datatypes
    }
	Date: 13-Mar-2003
 	Version: 1.7.0 ; majorv.minorv.status
				   ; status: 0: unfinished; 1: testing; 2: stable
	History: [
		 3-Mar-2003 1.1.0 "History start"
         4-Mar-2003 1.2.0 "Using new SUBFUNC from Ladislav (with minor adjustments)"
         5-Mar-2003 1.3.0 "Better version of SUBFUNC by Ladislav, no more requires highfun.r"
         6-Mar-2003 1.4.0 "Still experimenting with SUBFUNC :-)"
         6-Mar-2003 1.5.0 "New SUBFUNC and TSUBFUNC from Ladislav"
        10-Mar-2003 1.6.0 "Faster FUNCALL by Ladislav and Romano; minor adjustment to use it"
        13-Mar-2003 1.7.0 {
            First alpha version: the native actions in the global context are
            left untouched; an ACTIONS* context is provided with the patched
            actions; they are also defined in the global context with a * suffix
            (i.e. PICK* etc.).
        }
	]
]

do %subfunc.r

mk-action: func [
    action [action! native!]
    dispatch [word!]
    name [word!]
    spec [block!]
    transp [logic!]
] [
    either transp [
        tsubfunc :action spec compose/deep/only [
            ;print [(form name) "called"]
            either custom-type? (to get-word! dispatch) [
                use [type actions action] [
                    type: (head insert insert make path! 4 dispatch 'type)
                    either all [actions: in __actions type action: in get actions (to lit-word! name)] [
                        do funcall [return] action (prepare-ar spec)
                    ] [
                        throw make error! join "Action " [(form name) " not defined for " type]
                    ]
                ]
            ] [
                return super
            ]
        ]
    ] [
        subfunc :action spec compose/deep/only [
            ;print [(form name) "called"]
            either custom-type? (to get-word! dispatch) [
                use [type actions action] [
                    type: (head insert insert make path! 4 dispatch 'type)
                    either all [actions: in __actions type action: in get actions (to lit-word! name)] [
                        throw try funcall [return] action (prepare-ar spec)
                    ] [
                        throw make error! join "Action " [(form name) " not defined for " type]
                    ]
                ]
            ] [
                throw try [return super]
            ]
        ]
    ]
]

custom-type?: func [value] [
    all [object? :value [custom-type: custom-type type:] = copy/part third value 3]
]

__actions: context [ ]

custom-type!: context [
    custom-type: 'custom-type
    type: 'custom-type!
    actions: func [code [block!] /local tmp spec] [
        __actions: make __actions compose/only/deep [
            (to set-word! type) make either object? get/any (to lit-word! type) [(type)] [object!] (code)
        ]
        foreach word next first get in __actions type [
            if not value? word: in system/words word [
                set word func 
                    load mold spec: third tmp: get in get in __actions type word 
                    compose/deep/only [
                        either custom-type? (to get-word! tmp: first first :tmp) [
                            use [type actions action] [
                                type: (head insert insert make path! 2 tmp 'type)
                                either all [actions: in __actions type action: in get actions (to lit-word! word)] [
                                    do funcall [return] action (prepare-ar spec)
                                ] [
                                    make error! join "Action " [(form word) " not defined for " type]
                                ]
                            ]
                        ] [
                            make error! "Can only be used on custom types"
                        ]
                    ]
            ]
        ]
    ]
]

type?*: subfunc :type? [
    "Returns a value's datatype."
    value [any-type!]
    /word "Returns the datatype as a word."
] [
    either all [value? 'value custom-type? :value] [
        value/type
    ] [
        super
    ]
]

actions*: [
    type?: get in system/words 'type?*
]

foreach [action spec transp] [
    absolute [
        "Returns the absolute value."  [catch]
        value [number! pair! money! time! object!]
    ]   no
    add [
        "Returns the result of adding two values."  [catch]
        value1 [number! pair! char! money! date! time! tuple! object!] 
        value2 [number! pair! char! money! date! time! tuple! object!]
    ]   no
    and~ [
        "Returns the first value ANDed with the second."  [catch]
        value1 [logic! number! char! tuple! binary! image! object!] 
        value2 [logic! number! char! tuple! binary! image! object!]
    ]   no
    at [
        "Returns the series at the specified index."  [catch]
        series [series! object!] 
        index [number! logic!] "Can be positive, negative, or zero."
    ]   no
    back [
        "Returns the series at its previous position."  [catch]
        series [series! port! object!]
    ]   no
    change [
        {Changes a value in a series and returns the series after the change.}  [catch]
        series [series! port! object!] "Series at point to change" 
        value [any-type!] "The new value" 
        /part {Limits the amount to change to a given length or position.} 
        range [number! series! port! object!] 
        /only "Changes a series as a series." 
        /dup "Duplicates the change a specified number of times." 
        count [number!]
    ]   no
    clear [
        {Removes all values from the current index to the tail. Returns at tail.}  [catch]
        series [series! port! bitset! none! object!]
    ]   no
    complement [
        "Returns the one's complement value."  [catch]
        value [logic! number! char! tuple! bitset! object!]
    ]   no
    copy [
        "Returns a copy of a value."  [catch]
        value [series! port! bitset! object!] "Usually a series" 
        /part "Limits to a given length or position." 
        range [number! series! port! object!] 
        /deep "Also copies series values within the block."
    ]   no
    divide [
        "Returns the first value divided by the second."  [catch]
        value1 [number! pair! char! money! time! tuple! object!] 
        value2 [number! pair! char! money! time! tuple! object!]
    ]   no
    empty? [
        "Returns TRUE if a series is at its tail."  [catch]
        series [series! port! bitset! object!]
    ]   no
    equal? [
        "Returns TRUE if the values are equal."  [catch]
        value1 value2
    ]   no
    even? [
        "Returns TRUE if the number is even."  [catch]
        number [number! char! date! money! time! object!]
    ]   no
    fifth [
        "Returns the fifth value of a series."  ;[catch]
        series [series! money! date! port! tuple! event! object!]
    ]   yes
    find [
        {Finds a value in a series and returns the series at the start of it.}  [catch]
        series [series! port! bitset! object!] 
        value [any-type!] 
        /part "Limits the search to a given length or position." 
        range [number! series! port! object!] 
        /only "Treats a series value as a single value." 
        /case "Characters are case-sensitive." 
        /any "Enables the * and ? wildcards." 
        /with "Allows custom wildcards." 
        wild [string!] "Specifies alternates for * and ?" 
        /skip "Treat the series as records of fixed size" 
        size [integer!] 
        /match {Performs comparison and returns the tail of the match.} 
        /tail "Returns the end of the string." 
        /last "Backwards from end of string." 
        /reverse "Backwards from the current position."
    ]   no
    first [
        "Returns the first value of a series."  ;[catch]
        series [series! pair! event! money! date! object! port! time! tuple! any-function! library! struct! event! object!]
    ]   yes
    fourth [
        "Returns the fourth value of a series."  ;[catch]
        series [series! money! date! port! tuple! event! object!]
    ]   yes
    greater-or-equal? [
        {Returns TRUE if the first value is greater than or equal to the second value.}  [catch]
        value1 value2
    ]   no
    greater? [
        {Returns TRUE if the first value is greater than the second value.}  [catch]
        value1 value2
    ]   no
    head [
        "Returns the series at its head."  [catch]
        series [series! port! object!]
    ]   no
    head? [
        "Returns TRUE if a series is at its head."  [catch]
        series [series! port! object!]
    ]   no
    index? [
        {Returns the index number of the current position in the series.}  [catch]
        series [series! port! object!]
    ]   no
    insert [
        {Inserts a value into a series and returns the series after the insert.}  [catch]
        series [series! port! bitset! object!] "Series at point to insert" 
        value [any-type!] "The value to insert" 
        /part "Limits to a given length or position." 
        range [number! series! port! object!] 
        /only "Inserts a series as a series." 
        /dup "Duplicates the insert a specified number of times." 
        count [number!]
    ]   no
    last [
        "Returns the last value of a series."  ;[catch]
        series [series! port! tuple! object!]
    ]   yes
    length? [
        {Returns the length of the series from the current position.}  [catch]
        series [series! port! tuple! bitset! struct! object!]
    ]   no
    lesser-or-equal? [
        {Returns TRUE if the first value is less than or equal to the second value.}  [catch]
        value1 value2
    ]   no
    lesser? [
        {Returns TRUE if the first value is less than the second value.}  [catch]
        value1 value2
    ]   no
    maximum [
        "Returns the greater of the two values."  [catch]
        value1 [number! pair! char! money! date! time! tuple! series! object!] 
        value2 [number! pair! char! money! date! time! tuple! series! object!]
    ]   no
    minimum [
        "Returns the lesser of the two values."  [catch]
        value1 [number! pair! char! money! date! time! tuple! series! object!] 
        value2 [number! pair! char! money! date! time! tuple! series! object!]
    ]   no
    multiply [
        "Returns the first value multiplied by the second."  [catch]
        value1 [number! pair! char! money! time! tuple! object!] 
        value2 [number! pair! char! money! time! tuple! object!]
    ]   no
    negate [
        "Changes the sign of a number."  [catch]
        number [number! pair! money! time! bitset! object!]
    ]   no
    negative? [
        "Returns TRUE if the number is negative."  [catch]
        number [number! char! money! time! object!]
    ]   no
    next [
        "Returns the series at its next position."  [catch]
        series [series! port! object!]
    ]   no
    not-equal? [
        "Returns TRUE if the values are not equal."  [catch]
        value1 value2
    ]   no
    odd? [
        "Returns TRUE if the number is odd."  [catch]
        number [number! char! date! money! time! object!]
    ]   no
    or~ [
        "Returns the first value ORed with the second."  [catch]
        value1 [logic! number! char! tuple! binary! image! object!] 
        value2 [logic! number! char! tuple! binary! image! object!]
    ]   no
    pick [
        {Returns the value at the specified position in a series.}  ;[catch]
        series [series! pair! event! money! date! time! object! port! tuple! any-function! object!] 
        index [number! logic!]
    ]   yes
    poke [
        {Returns value after changing its data at the given index. (See manual)}  [catch]
        value [series! money! date! time! object! port! tuple! object!] 
        index [number! logic!] 
        data "new value"
    ]   no
    positive? [
        "Returns TRUE if the value is positive."  [catch]
        number [number! char! money! time! object!]
    ]   no
    power [
        {Returns the first number raised to the second number.}  [catch]
        number [number! object!] 
        exponent [number! object!]
    ]   no
    random [
        "Returns a random value of the same datatype."  [catch]
        value "Maximum value of result" 
        /seed "Restart or randomize" 
        /secure "Returns a cryptographically secure random number." 
        /only "Return single value from series."
    ]   no
    remainder [
        {Returns the remainder of first value divided by second.}  [catch]
        value1 [number! pair! char! money! time! tuple! object!] 
        value2 [number! pair! char! money! time! tuple! object!]
    ]   no
    remove [
        {Removes value(s) from a series and returns after the remove.}  [catch]
        series [series! port! bitset! none! object!] 
        /part "Removes to a given length or position." 
        range [number! series! port! object!]
    ]   no
    same? [
        "Returns TRUE if the values are identical."  [catch]
        value1 
        value2
    ]   no
    second [
        "Returns the second value of a series."  ;[catch]
        series [series! pair! event! money! date! object! port! time! tuple! any-function! struct! event! object!]
    ]   yes
    select [
        {Finds a value in the series and returns the value or series after it.}  ;[catch]
        series [series! port! object!] 
        value [any-type!] 
        /part "Limits the search to a given length or position." 
        range [number! series! port! object!] 
        /only "Treats a series value as a single value." 
        /case "Characters are case-sensitive." 
        /any "Enables the * and ? wildcards." 
        /with "Allows custom wildcards." 
        wild [string!] "Specifies alternates for * and ?" 
        /skip "Treat the series as records of fixed size" 
        size [integer!]
    ]   yes
    skip [
        {Returns the series forward or backward from the current position.}  [catch]
        series [series! port! object!] 
        offset [number! logic!] "Can be positive, negative, or zero."
    ]   no
    sort [
        "Sorts a series."  [catch]
        series [series! port! object!] 
        /case "Case sensitive sort." 
        /skip "Treat the series as records of fixed size." 
        size [integer!] "Size of each record." 
        /compare "Comparator offset, block or function." 
        comparator [integer! block! function!] 
        /part "Sort only part of a series." 
        length [integer!] "Length of series to sort." 
        /all "Compare all fields" 
        /reverse "Reverse sort order"
    ]   no
    strict-equal? [
        {Returns TRUE if the values are equal and of the same datatype.}  [catch]
        value1 value2
    ]   no
    strict-not-equal? [
        {Returns TRUE if the values are not equal and not of the same datatype.}  [catch]
        value1 value2
    ]   no
    subtract [
        {Returns the second value subtracted from the first.}  [catch]
        value1 [number! pair! char! money! date! time! tuple! object!] 
        value2 [number! pair! char! money! date! time! tuple! object!]
    ]   no
    tail [
        {Returns the series at the position after the last value.}  [catch]
        series [series! port! object!]
    ]   no
    tail? [
        "Returns TRUE if a series is at its tail."  [catch]
        series [series! port! bitset! object!]
    ]   no
    third [
        "Returns the third value of a series."  ;[catch]
        series [series! money! date! port! time! tuple! any-function! struct! event! object! object!]
    ]   yes
    trim [
        {Removes whitespace from a string. Default removes from head and tail.}  [catch]
        series [series! port! object!] 
        /head "Removes only from the head." 
        /tail "Removes only from the tail." 
        /auto "Auto indents lines relative to first line." 
        /lines "Removes all line breaks and extra spaces." 
        /all "Removes all whitespace." 
        /with str [char! string!] "Same as /all, but removes characters in 'str'."
    ]   no
    xor~ [
        {Returns the first value exclusive ORed with the second.}  [catch]
        value1 [logic! number! char! tuple! binary! image! object!] 
        value2 [logic! number! char! tuple! binary! image! object!]
    ]   no
    zero? [
        "Returns TRUE if the number is zero."  [catch]
        number [number! pair! char! money! time! tuple! object!]
    ]   no
    
    form [
        "Converts a value to a string." [catch]
        value "The value to form"
    ]   no
] [
    set tmp2: to-word join action "*" tmp: mk-action get action first find spec word! action spec get transp
    insert insert insert tail actions* to set-word! action [get in system/words] to lit-word! tmp2
]
unset [tmp tmp2]
abs*: :absolute*
min*: :minimum*
max*: :maximum*
to*: tfunc [
    {Constructs and returns a new value after conversion.} 
    type [any-type!] "The datatype or example value." 
    spec [any-type!] "The attributes of the new value."

    /local actions action
] [
    either all [value? 'type custom-type? :type] [
        either all [actions: in __actions type/type action: in get actions 'to] [
            do funcall [return] action ['type 'spec]
        ] [
            throw make error! join "Action to not defined for " type/type
        ]
    ] [
        return to :type :spec
    ]
]
insert tail actions* [
    abs: :absolute
    min: :minimum
    max: :maximum
    to: get in system/words 'to*
]
actions*: context actions*

unset 'mk-action
halt