REBOL [
    Title: "Array tools."
    File: %array-tools.r 
    Author: "Brett Handley"
    Email: brett@codeconscious.com 
    Date: 17-Oct-2000
    Purpose: "Provide some utility functions for usings arrays."
    Comment: {
        Works on the structure returned by the array function.
    }
    History: [
        1.0.0 [17-Oct-2000 { Original code }  "Brett Handley"]
        1.0.0 [16-Nov-2000 { Added some more functions.}  "Brett Handley"]
    ]
    Note: "Includes a function by another author."
]

if not :use-script [use-script: :do]   ; Use-script is my script manager

use-script %series-tools.r

array-from-block: function [
    "Makes each row a block."
    block
    width [integer!] "Specifies the array width - like using skip."
][result-block cursor][
    result-block: make block! to-integer divide length? block width
    cursor: block
    forskip cursor width [
        insert/only tail result-block copy/part cursor width
    ]
    result-block
]

array-project: function [
    "Creates a new array from the old one using the specified columns."
    m
    cols [series!] "Series of column indexes."
    /series "Returns references to element positions rather than copies of elements."
][mp r c][
    r: length? m
    c: length? m/1
    mp: array reduce [r length? cols]
    repeat i r [
        repeat j length? cols [
            poke pick mp i j
                either series [
                    at pick m i pick cols j
                ][
                    pick pick m i pick cols j
                ]
        ]
    ]
    mp
]

array-select: function [
    "Selects rows from an array based on function."
    m
    filter  "A function to filter the rows - must take row as argument."
    /indexes "Returns row indexes rather the rows."
][ms r rr][
    r: length? m
    c: length? m/1
    ms: copy []
    repeat i r [
        if filter rr: pick m i [
            either indexes [
                insert/only tail ms i
            ][  
                insert/only tail ms rr
            ]
        ]
    ]
    ms
]

array-join: function [
    "Joins two arrays together using a join function."
    a
    b
    join-condition "A function determines to make the join - must take two arguments."
    /project "Applies projections before returning result."
        cols-a cols-b
][mj ra rb row-a row-b][
    ra: length? a
    rb: length? b
    mj: copy []
    repeat i ra [
        repeat j rb [
            if join-condition (row-a: pick a i) (row-b: pick b j) [
                either project [
                    insert/only tail mj probe
                        head insert (tail flatten array-project reduce [row-a] cols-a)
                            (flatten array-project reduce [row-b] cols-b)
                ][
                    insert/only tail mj head insert tail copy row-a row-b
                ]
            ]
        ]
    ]
    mj
]

array-load: function [
    "Changes columns into loaded values."
    m
    /columns cols [series!] "Series of specific column indexes to load."
    /in-place "Changes source array, instead of making a copy of the array."
    /thousands "Changes , to '"
][mp r c col-num value][
    if not columns [
        cols: copy []
        repeat i length? m/1 [insert tail cols i]
    ]
    either in-place [ mp: m ] [mp: copy/deep m]
    r: length? m
    c: length? m/1
    repeat i r [
        repeat j length? cols [
            col-num: pick cols j
            value: pick pick m i col-num
            if value [
                if thousands [
                    value: replace/all value "," "'"
                ]
                value: load value
            ]
            change at pick mp i col-num value
        ]
    ]
    mp
]


; Author - Gerald Goertzel (Posted by Larry to list@rebol.com)
transpose: func [m /local r c mt] [
   r: length? m
   c: length? m/1
   mt: array reduce [c r]
   repeat i r [
      repeat j c [
         poke pick mt j i  pick pick  m i j
      ]
   ]
   mt
]

occurrence: function [
    [catch]
    array
    column-index "Column to group."
    /map "Applies a function to each row and then chooses column from this result." map-func [function!]
][index-hash count-block cursor count-record item][
    index-hash: make hash! 500
    count-block: make block! 500
    foreach row array [
        either map [ item: pick map-func row column-index ] [ item: row/:column-index ]
        if not cursor: find/only index-hash item [
            cursor: back insert/only tail index-hash item
            insert/only tail count-block reduce [item 0]
        ]
        count-record: pick count-block index? cursor
        count-record/2: add 1 count-record/2
    ]
    :count-block
]

array-search: function [
    "Returns first row that satisfies condition."
    array [series!]
    condition [function!] "Take row as an argument."
    /prior "Returns row prior to the one the search terminated on."
][cursor][
    cursor: array
    while [all [not tail? cursor not condition cursor/1]][ cursor: next cursor ]
    either prior [
        either equal? index? cursor 1 [
            none
        ][
            back cursor
        ]
    ][
        either tail? cursor [
            none
        ][
            cursor/1
        ]
    ]
]

threshold: func [
    "Returns the threshold row, the first row where Value < Column1 (endpoints)."
    array [series!]
    value
    /start-points "Returns the last row that satisfies Value >= Column1 (startpoints)."
][
    either start-points [
        array-search/prior array func[x] [greater? x/1 value]
    ][
        array-search array func[x] [x not lesser? x/1 value]
    ]
]

default: func[
    "Returns the default value, if value is none"
    value
    default
][
    either value [value][default]
]

array-from-block-ex: function [
    "Changes fixed length encoding to variable length."
    loaded-table [block!]
    size [integer!]
    /in-place "Changes given block rather than returning a copy of data."
    /preserve-none "Preserve 'none instead of trimming it from each row."
][result row-start trim-nones current-row][

    either in-place [

        row-start: loaded-table

        while [not tail? row-start][
            row-start: insert/only row-start current-row: copy/part row-start size
            if not preserve-none [
                while [ all [greater? length? current-row 0 equal? last current-row 'none] ] [
                    remove back tail current-row
                ]
            ]
            row-start: remove/part row-start size
        ]

    ][
        either preserve-none [
            array-from-block-ex/in-place/preserve-none result: copy/deep loaded-table size
        ][
            array-from-block-ex/in-place result: copy/deep loaded-table size
        ]
        return result
    ]

]

block-from-array: function [
    "Changes variable length encoding to fixed length."
    loaded-table [block!] "Assumes a block of rows - each row being a block of values."
    new-length [integer!]
    /in-place "Changes given block rather than returning a copy of data."
][result current-row table-cursor more-rows has-split][

    either in-place [

        ; Process in reverse in case we split rows.
        table-cursor: tail loaded-table
        more-rows: greater? length? loaded-table 0
        while [more-rows] [
            ; get a row
            table-cursor: back table-cursor
            current-row: table-cursor/1

            ; Do we need to split the row?
            either greater? length? current-row new-length [
                insert/only next table-cursor copy/part at current-row add new-length 1 subtract length? current-row new-length
                clear at current-row add new-length 1

                ; Better process the newly created row
                table-cursor: next next table-cursor
                has-split: yes
            ][
                has-split: no
            ]

            if not has-split [

                ; Do we need to extend the row?
                if lesser? length? current-row new-length [
                    insert/dup tail current-row 'none subtract new-length length? current-row
                ]

                ; We're done with the row shell now let get rid of it.
                for i length? current-row 1 -1 [
                    insert next table-cursor pick current-row i
                ]
                remove table-cursor

            ]

            ; more to do?
            more-rows: greater? index? table-cursor 1
        ]

    ][
        block-from-array/in-place result: copy/deep loaded-table new-length
        return result
    ]
]