REBOL [
    Title: "Prevalent block"
    Purpose: {
        Defines the pblock! type, Prevayler-alike implementation
    }
    Author: "Gabriele Santilli"
    EMail: giesse@rebol.it
    File: %prevalent-block.r
    License: {
Copyright (C) 2003  Gabriele Santilli

This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
as published by the Free Software Foundation; either version 2
of the License, or (at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.

http://www.gnu.org/copyleft/gpl.html
    }
    Date: 9-Nov-2004
    Version: 1.8.0 ; majorv.minorv.status
                   ; status: 0: unfinished; 1: testing; 2: stable
    History: [
        18-Oct-2004 1.1.0 "History start"
        19-Oct-2004 1.2.0 "First version"
        19-Oct-2004 1.3.0 "INVALID-ARG -> INVALID-ARGUMENT"
        29-Oct-2004 1.4.0 "Implemented new DISMANTLE/REBUILD; fixed bugs in HEAD/TAIL/NEXT/BACK; other minor changes"
        29-Oct-2004 1.5.0 "Removed safety checks in REBUILD"
         9-Nov-2004 1.6.0 "Added SERIES?*"
         9-Nov-2004 1.7.0 "Simplified logging (now series positions are preserved)"
         9-Nov-2004 1.8.0 "Added SET-IN and GET-IN; fixed FIND"
    ]
]

; define custom actions here

; type definition

define-type 'pblock! [
    id: none
    values: [ ]
] [
    ; type actions. please support all standard actions (possibly throwing an error)
    
    add' ; action name
    ;[
    ;    "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!]
    ;]
    [ ] ; local words for this action
    [
        invalid-argument :value1
    ]
    
    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!]
    ;]
    [ ]
    [
        invalid-argument :value1
    ]
    
    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!]
    ;]
    [ ]
    [
        invalid-argument :value1
    ]
    
    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!]
    ;]
    [ ]
    [
        invalid-argument :value1
    ]
    
    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!]
    ;]
    [ ]
    [
        invalid-argument :value1
    ]
    
    power'
    ;[
    ;    {Returns the first number raised to the second number.} [catch] 
    ;    number [number! object!] 
    ;    exponent [number! object!]
    ;]
    [ ]
    [
        invalid-argument :number
    ]
    
    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!]
    ;]
    [ ]
    [
        invalid-argument :value1
    ]
    
    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!]
    ;]
    [ ]
    [
        invalid-argument :value1
    ]
    
    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!]
    ;]
    [ ]
    [
        invalid-argument :value1
    ]
    
    same?'
    ;[
    ;    "Returns TRUE if the values are identical." [catch] 
    ;    value1 
    ;    value2
    ;]
    [ ]
    [
        same? :value1 :value2
    ]
    
    equal?'
    ;[
    ;    "Returns TRUE if the values are equal." [catch] 
    ;    value1 value2
    ;]
    [ ]
    [
        either custom-type? :value2 [
            equal?* value2 value1/values
        ] [
            throw-on-error [equal? value1/values :value2]
        ]
    ]
    
    strict-equal?'
    ;[
    ;    {Returns TRUE if the values are equal and of the same datatype.} [catch] 
    ;    value1 value2
    ;]
    [ ]
    [
        all ['pblock! = type?* :value2  value1/values = value2/values]
    ]
    
    not-equal?'
    ;[
    ;    "Returns TRUE if the values are not equal." [catch] 
    ;    value1 value2
    ;]
    [ ]
    [
        either custom-type? :value2 [
            not-equal?* value2 value1/values
        ] [
            throw-on-error [not-equal? value1/values :value2]
        ]
    ]
    
    strict-not-equal?'
    ;[
    ;    {Returns TRUE if the values are not equal and not of the same datatype.} [catch] 
    ;    value1 value2
    ;]
    [ ]
    [
        any ['pblock! <> type?* :value2  value1/values <> value2/values]
    ]
    
    greater?'
    ;[
    ;    {Returns TRUE if the first value is greater than the second value.} [catch] 
    ;    value1 value2
    ;]
    [ ]
    [
        invalid-argument :value1
    ]
    
    lesser?'
    ;[
    ;    {Returns TRUE if the first value is less than the second value.} [catch] 
    ;    value1 value2
    ;]
    [ ]
    [
        invalid-argument :value1
    ]
    
    greater-or-equal?'
    ;[
    ;    {Returns TRUE if the first value is greater than or equal to the second value.} [catch] 
    ;    value1 value2
    ;]
    [ ]
    [
        invalid-argument :value1
    ]
    
    lesser-or-equal?'
    ;[
    ;    {Returns TRUE if the first value is less than or equal to the second value.} [catch] 
    ;    value1 value2
    ;]
    [ ]
    [
        invalid-argument :value1
    ]
    
    negate'
    ;[
    ;    "Changes the sign of a number." [catch] 
    ;    number [number! pair! money! time! bitset! object!]
    ;]
    [ ]
    [
        invalid-argument :number
    ]
    
    complement'
    ;[
    ;    "Returns the one's complement value." [catch] 
    ;    value [logic! number! char! tuple! bitset! object!]
    ;]
    [ ]
    [
        invalid-argument :value
    ]
    
    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."
    ;]
    [ ]
    [
        if seed [invalid-argument :value]
        value: value/values
        value: do sixth second :random*
        either only [
            :value
        ] [
            make* pblock! :value
        ]
    ]
    
    odd?'
    ;[
    ;    "Returns TRUE if the number is odd." [catch] 
    ;    number [number! char! date! money! time! object!]
    ;]
    [ ]
    [
        invalid-argument :number
    ]
    
    even?'
    ;[
    ;    "Returns TRUE if the number is even." [catch] 
    ;    number [number! char! date! money! time! object!]
    ;]
    [ ]
    [
        invalid-argument :number
    ]
    
    negative?'
    ;[
    ;    "Returns TRUE if the number is negative." [catch] 
    ;    number [number! char! money! time! object!]
    ;]
    [ ]
    [
        invalid-argument :number
    ]
    
    positive?'
    ;[
    ;    "Returns TRUE if the value is positive." [catch] 
    ;    number [number! char! money! time! object!]
    ;]
    [ ]
    [
        invalid-argument :number
    ]
    
    zero?'
    ;[
    ;    "Returns TRUE if the number is zero." [catch] 
    ;    number [number! pair! char! money! time! tuple! object!]
    ;]
    [ ]
    [
        invalid-argument :number
    ]
    
    head'
    ;[
    ;    "Returns the series at its head." [catch] 
    ;    series [series! port! object!]
    ;]
    [ ]
    [
        make series [values: head series/values] ; does not create a new persistant value!
    ]
    
    tail'
    ;[
    ;    {Returns the series at the position after the last value.} [catch] 
    ;    series [series! port! object!]
    ;]
    [ ]
    [
        make series [values: tail series/values]
    ]
    
    head?'
    ;[
    ;    "Returns TRUE if a series is at its head." [catch] 
    ;    series [series! port! object!]
    ;]
    [ ]
    [
        head? series/values
    ]
    
    tail?'
    ;[
    ;    "Returns TRUE if a series is at its tail." [catch] 
    ;    series [series! port! bitset! object!]
    ;]
    [ ]
    [
        tail? series/values
    ]
    
    next'
    ;[
    ;    "Returns the series at its next position." [catch] 
    ;    series [series! port! object!]
    ;]
    [ ]
    [
        make series [values: next series/values]
    ]
    
    back'
    ;[
    ;    "Returns the series at its previous position." [catch] 
    ;    series [series! port! object!]
    ;]
    [ ]
    [
        make series [values: back series/values]
    ]
    
    skip'
    ;[
    ;    {Returns the series forward or backward from the current position.} [catch] 
    ;    series [series! port! object!] 
    ;    offset [number! logic! pair!] "Can be positive, negative, or zero."
    ;]
    [ ]
    [
        make series [values: skip series/values offset]
    ]
    
    at'
    ;[
    ;    "Returns the series at the specified index." [catch] 
    ;    series [series! port! object!] 
    ;    index [number! logic! pair!] "Can be positive, negative, or zero."
    ;]
    [ ]
    [
        make series [values: at series/values index]
    ]
    
    index?'
    ;[
    ;    {Returns the index number of the current position in the series.} [catch] 
    ;    series [series! port! object!]
    ;]
    [ ]
    [
        index? series/values
    ]
    
    length?'
    ;[
    ;    {Returns the length of the series from the current position.} [catch] 
    ;    series [series! port! tuple! bitset! struct! object!]
    ;]
    [ ]
    [
        length? series/values
    ]
    
    pick'
    ;[
    ;    {Returns the value at the specified position in a series.} [catch] 
    ;    series [series! pair! event! money! date! time! object! port! tuple! any-function!] 
    ;    index [number! logic! pair!]
    ;]
    [ ]
    [
        pick series/values index
    ]
    
    last'
    ;[
    ;    "Returns the last value of a series." [catch] 
    ;    series [series! port! tuple! object!]
    ;]
    [ ]
    [
        last series/values
    ]
    
    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."
    ;]
    [ ]
    [
        if object? range [
            if not all ['pblock! = type?* range same? head series/values head range/values] [
                invalid-argument range
            ]
            range: range/values
        ]
        make series [
            set 'series series/values
            values: do sixth second :find*
            if not values [return none]
        ]
    ]
    
    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!]
    ;]
    [ ]
    [
        if object? range [
            if not all ['pblock! = type?* range same? head series/values head range/values] [
                invalid-argument range
            ]
            range: range/values
        ]
        series: series/values
        do sixth second :select*
    ]
    
    make'
    ;[
    ;    "Constructs and returns a new value." [catch] 
    ;    type [any-type!] "The datatype or example value." 
    ;    spec [any-type!] "The attributes of the new value."
    ;]
    [ ]
    [
        switch/default type?* get/any 'spec [
            block! [spec: copy spec]
            pblock! [spec: copy spec/values]
        ] [
            spec: to* block! :spec
        ]
        log-operation compose/only [
            make* pblock! (spec)
        ]
        make pblock! [
            id: register-value self
            values: spec
        ]
    ]
    
    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! pair! object!] 
    ;    /deep "Also copies series values within the block."
    ;]
    [ ]
    [
        if object? range [
            either all ['pblock! = type?* range  same? head value/values head range/values] [
                range: range/values
            ] [
                invalid-argument range
            ]
        ]
        value: value/values
        make* pblock! do sixth second :copy*
    ]
    
    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! pair! object!] 
    ;    /only "Inserts a series as a series." 
    ;    /dup "Duplicates the insert a specified number of times." 
    ;    count [number! pair!]
    ;]
    [path operation]
    [
        if object? range [
            if not all ['pblock! = type?* range same? head series/values head range/values] [
                invalid-argument range
            ]
        ]
        operation: reduce [path: make path! [insert*] series 'first reduce [get/any 'value]]
        if part [
            insert tail path 'part
            insert/only tail operation range
        ]
        if only [insert tail path 'only]
        if dup [
            insert tail path 'dup
            insert tail operation count
        ]
        log-operation operation
        if object? range [range: range/values]
        make series [
            set 'series series/values
            values: do sixth second :insert*
        ]
    ]
    
    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! pair! object!]
    ;]
    [path operation]
    [
        if object? range [
            if not all ['pblock! = type?* range same? head series/values head range/values] [
                invalid-argument range
            ]
        ]
        operation: reduce [path: make path! [remove*] series]
        if part [
            insert tail path 'part
            insert/only tail operation range
        ]
        log-operation operation
        if object? range [range: range/values]
        make series [
            set 'series series/values
            values: do sixth second :remove*
        ]
    ]
    
    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! pair! object!] 
    ;    /only "Changes a series as a series." 
    ;    /dup "Duplicates the change a specified number of times." 
    ;    count [number! pair!]
    ;]
    [path operation]
    [
        if object? range [
            if not all ['pblock! = type?* range same? head series/values head range/values] [
                invalid-argument range
            ]
        ]
        operation: reduce [path: make path! [change*] series 'first reduce [get/any 'value]]
        if part [
            insert tail path 'part
            insert/only tail operation range
        ]
        if only [insert tail path 'only]
        if dup [
            insert tail path 'dup
            insert tail operation count
        ]
        log-operation operation
        if object? range [range: range/values]
        make series [
            set 'series series/values
            values: do sixth second :change*
        ]
    ]
    
    poke'
    ;[
    ;    {Returns value after changing its data at the given index. (See manual)} [catch] 
    ;    value [series! money! date! time! object! port! tuple!] 
    ;    index [number! logic! pair!] 
    ;    data "new value"
    ;]
    [ ]
    [
        log-operation reduce [
            'poke* value index 'first reduce [:data]
        ]
        poke value/values index :data
    ]
    
    clear'
    ;[
    ;    {Removes all values from the current index to the tail. Returns at tail.} [catch] 
    ;    series [series! port! bitset! none! object!]
    ;]
    [ ]
    [
        log-operation reduce [
            'clear* series
        ]
        clear series/values
    ]
    
    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'."
    ;]
    [ ]
    [
        invalid-argument :series
    ]
    
    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"
    ;]
    [path operation orig]
    [
        operation: reduce [path: make path! [sort*] series]
        if case [insert tail path 'case]
        if skip [
            insert tail path 'skip
            insert tail operation size
        ]
        if compare [
            insert tail path 'compare
            insert tail operation reduce ['first reduce [:comparator]]
        ]
        if part [
            insert tail path 'part
            insert tail operation length
        ]
        if all [insert tail path 'all]
        if reverse [insert tail path 'reverse]
        log-operation operation
        orig: series
        series: series/values
        do sixth second :sort*
        orig
    ]
    
    min'
    ;[
    ;    "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!]
    ;]
    [ ]
    [
        invalid-argument :value1
    ]
    
    max'
    ;[
    ;    "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!]
    ;]
    [ ]
    [
        invalid-argument :value1
    ]
    
    abs'
    ;[
    ;    "Returns the absolute value." [catch] 
    ;    value [number! pair! money! time! object!]
    ;]
    [ ]
    [
        invalid-argument :value
    ]
    
    empty?'
    ;[
    ;    "Returns TRUE if a series is at its tail." [catch] 
    ;    series [series! port! bitset! object!]
    ;]
    [ ]
    [
        empty? series/values
    ]

    prevalent?'
    ;[
    ;    "Returns true if the value is prevalent (i.e. is of one of the Prevayler-alike persistent types)"
    ;    value [object!]
    ;]
    [ ]
    [
        true
    ]
    
    id?'
    ;[
    ;    "Returns the ID of a prevalent value"
    ;    value [object!]
    ;]
    [ ]
    [
        value/id
    ]

    dismantle'
    ;[
    ;    "Dismantles the value into pieces that can be used by REBUILD to recreate it"
    ;    value [object!]
    ;]
    [ ]
    [
        reduce [
            'dismantled
            'pblock!
            value/id
            dismantle-block copy/deep value/values
        ]
    ]

    rebuild'
    ;[
    ;    "Rebuild a dismantled value"
    ;    pieces [block!]
    ;]
    [value]
    [
        value: make pblock! [
            id: third pieces
            values: copy/deep fourth pieces
        ]
        register-value value ; help rebuild the world, and avoid infinite recursion in case of self references
        rebuild-block value/values
        value
    ]

    series?'
    ;["Returns TRUE for series values." value [any-type!]]
    [ ]
    [
        true
    ]

    get-in'
    ;[
    ;    "Get an attribute of a value" [catch]
    ;    value [object!]
    ;    attribute
    ;    /default defval "Default value to return (instead of NONE)"
    ;]
    [ ]
    [
        either integer? :attribute [
            pick* value attribute
        ] [
            select* value :attribute
        ]
    ]
    
    set-in'
    ;[
    ;    "Set an attribute of a value" [catch]
    ;    target [object!]
    ;    attribute
    ;    value
    ;]
    [ ]
    [
        either integer? :attribute [
            poke* target attribute :value
        ] [
            if not target: find* target :attribute [invalid-argument :attribute]
            change*/only next* target :value
            :value
        ]
    ]
]