REBOL [
    Title: "Formatting functions"
    File: %format.r
    Author: "Eric Long"
    Email: kgd03011@nifty.ne.jp
    Date: 20-Feb-2000
    Category: [utility math]
    Version: 1.0.3
    Purpose: {
        A few functions for formatting.

        FORMAT aims to be a Reboloid replacement for sprintf.
        It converts data into strings, with rounding of decimal
        values, choice of scientific or fixed-point notation,
        padding to a given length, and right and left justification.
        FORMAT also handles blocks of data, with corresponding blocks
        of formatting options to be applied to successive items.

        QT is useful for printing out long blocks of words or numerical
        data, and QC formats and prints out tabular data stored in
        nested blocks.

        FULL-FORM returns a string representation of a decimal that will
        load back to exactly the original value. All values that correspond
        to an exact integer up to 2 ** 53 are represented as an integer.
    }
    Acknowledgements: {
        Many thanks to Larry Palmiter and Gerald Goertzel, who tested
        these functions and suggested many improvements. The idea of
        FULL-FORM is originally Larry's, and the development of the
        code was a collaboration among the three of us.

        Thanks to Carl for suggesting the best way to pass the options
        argument.
    }
]

comment {      ================ FORMAT REFORMAT ================

REFORMAT is a shortcut to reduce a block before applying FORMAT.

EXAMPLES:

>> format pi #.4
== "3.1416"

>> reformat/full [pi exp 1] #.15                 ; greater precision than FORM
== ["3.141592653589793" "2.718281828459045"]

>> format 2 ** 32 #.-6.8                         ; round to nearest million
== "4,295,000,000"                               ; insert commas option

>> reformat [pi exp 1 square-root 2] [#8.4 #6.2] ; width specified
== ["  3.1416" "  2.72" "  1.41"]

>> format 2 ** 40 #.5.1                          ; scientific notation
== "1.09951E+012"

>> reformat ["pi =" pi] #7.4.2                   ; auto-justification
== ["pi =   " " 3.1416"]

>> reformat ["very long string" 2 ** 32] #6.0.4  ; truncation of string
== ["string" "4294967296"]

>> reformat ["very long string" 2 ** 32] #4.0.6  ; ... plus auto-justification
== ["very" "4294967296"]

>> format $20 / 3 #.4                            ; money values handled
== "$6.6667"                                     ; just like number values

>> format now #0                                 ; inserts zeroes into dates
== "06-Feb-2000/13:19"                           ; and times for alignment
}

format: func [
    {Converts Rebol data into formatted strings.}
    item "value or block of values to format"
    options [block! any-string!]
        {single option, or block of options to be applied successively to
        a block of items (with last option used repeatedly if necessary).
        Formed options are parsed to integers: A.B.C
            A       width of formatted string
                    (negative for left justified)
            B       precision to right of decimal point
                    (negative for rounding to left of decimal point)
            C and 1 scientific notation
            C and 2 auto justification (number! and money! right justified)
            C and 4 truncate string values
            C and 8 insert commas
            C and 16 prefix value with '$'} ; Added by Mike Yaunish

    /full  "use extra precision in forming decimal values"
    /local n fraction exponent neg decimal
   scientific width left-j trunc commas
   ptr round-off-point format-path prefix
][
    either data-block? :item [
        ; process block
        if object? :item        [ item: next second item ]
        format-path: make path! [format]
        if full [insert tail :format-path 'full]
        if not block? options   [ options: reduce [options] ]
        n: to block! :item
        while [not tail? n][
            either data-block? item: first n [
                        ; recurse with all format values
                change/only n format-path :item head options
            ][
                        ; use current format value
                change/only n format-path :item first options
            ]
            n: next n
                            ; get next format values, or reuse the last one
            if 1 < length? options [ options: next options ]
        ]
    ][
        ; process single value
        if block? options     [ options: first options ]
        set [width decimal options] parse-integers/def options [0 0 0]
        if negative? width [width: - width  left-j: true]
        if not zero? 1 and options [scientific: true  decimal: abs decimal]
        if not zero? 2 and options [
            left-j: not any [number? :item  money? :item]
        ]
        if all [
            not zero? 4 and options
            not zero? width
            string? :item
        ][trunc: true]
        if not zero? 8 and options [commas: true]
        if not zero? 16 and options [
            prefix: "$"
        ]
        if money? :item [
            prefix: append item/1 "$"
            item: item/2
        ]

        either number? :item [
            ; format number value
            if negative? item [item: - item  neg: true]
            n: either full [full-form item][form item]

            ; find the power of ten
            either ptr: find n "E" [
                exponent: to integer! next ptr
                clear ptr
            ][
                exponent: 0
            ]
            either ptr: find n "." [
                remove ptr
            ][
                ptr: tail n
            ]
            exponent: exponent - 2 + index? ptr

            ; round off to the desired precision
            round-off-point: either scientific [
                while [ #"0" = pick n 1 ] [
                    exponent: exponent - 1
                    remove n
                ]
                decimal + 1
            ][
                decimal + exponent + 1
            ]
            either round-off-point < length? n [
                either negative? round-off-point [n: copy "0"][
                    fraction: copy skip n round-off-point
                    either zero? round-off-point [n: copy "0"][
                        clear skip n round-off-point
                    ]
                    if positive? to integer! .5 +
                            to decimal! head insert fraction "." [
                        n: to string! 1 + to integer! n
                    ]
                ]
            ][
                insert/dup tail n "0" round-off-point - length? n
            ]

            either scientific [
                if positive? decimal [insert next n "."]
                insert tail n "E"
                either negative? exponent [
                    insert tail n "-"
                    exponent: - exponent
                ][
                    insert tail n "+"
                ]
                exponent: form exponent
                insert/dup exponent "0" 3 - length? exponent
                insert tail n exponent
            ][
                either positive? decimal [
                    insert/dup n "0" decimal + 1 - length? n
                    insert skip tail n (- decimal) "."
                ][
                    if all [
                        negative? decimal
                        n <> "0"
                    ][
                        insert/dup tail n "0" (- decimal)
                    ]
                ]
            ]
            if commas [
                if not ptr: find n "." [ ptr: tail n ]
                ptr: skip ptr -3
                while [ not head? ptr ] [
                    insert ptr ","
                    ptr: skip ptr -3
                ]
            ]
            if prefix [insert n prefix]
            if neg [insert n "-"]
            ; number value now formatted
        ][
            either any [date? :item  time? :item][
                n: form item
                ; remove time zone data if any
                if ptr: find n "+" [ clear ptr ]
                ; add zeroes to line up columns
                if #"-" = second n [ insert n "0" ]
                ptr: either ptr: find n #"/" [next ptr][n]
                if #":" = second ptr [ insert ptr "0" ]
                ; remove seconds if any
                parse n [ thru ":" to ":" ptr: (clear ptr)]
            ][
                either any-word? :item [
                    n: mold :item
                ][
                    n: form :item
                ]
            ]
        ]
        ; pad with spaces
        either left-j [
            if trunc [n: copy/part n width]
            insert/dup tail n " " width - length? n
        ][
            if trunc [n: copy skip tail n (- width)]
            insert/dup n " " width - length? n
        ]
    ]
    head n
]

reformat: func [
    {Reduces and formats the items in a block}
    b        "block to format"
    options  [block! any-string!]
    {Formatting options. Do "help format" for more information}
    /full    "use extra precision in forming decimal values"
][
    either full [
        format/full reduce b options
    ][
        format reduce b options
    ]
]

comment {      ================ QT ================

EXAMPLES:

>> arr: copy [] repeat x 25 [append arr log-e x]
== [0 0.693147180559945 1.09861228866811 1.38629436111989 ...

>> qt arr
0.0000 0.6931 1.0986 1.3863 1.6094 1.7918 1.9459 2.0794 2.1972 2.3026 2.3979
2.4849 2.5649 2.6391 2.7081 2.7726 2.8332 2.8904 2.9444 2.9957 3.0445 3.0910
3.1355 3.1781 3.2189

>> qt/o arr #.2
0.00 0.69 1.10 1.39 1.61 1.79 1.95 2.08 2.20 2.30 2.40 2.48 2.56 2.64 2.71
2.77 2.83 2.89 2.94 3.00 3.04 3.09 3.14 3.18 3.22

>> qt/o arr #.2..2                               ; two extra spaces
0.00   0.69   1.10   1.39   1.61   1.79   1.95   2.08   2.20   2.30   2.40
2.48   2.56   2.64   2.71   2.77   2.83   2.89   2.94   3.00   3.04   3.09
3.14   3.18   3.22

>> arr: copy [] repeat x 20 [append arr exp x]
== [2.71828182845905 7.38905609893065 20.0855369231877 ...

>> qt arr
        2.7183         7.3891        20.0855        54.5982       148.4132
      403.4288      1096.6332      2980.9580      8103.0839     22026.4658
    59874.1417    162754.7914    442413.3920   1202604.2842   3269017.3725
  8886110.5205  24154952.7536  65659969.1373 178482300.9632 485165195.4098

>> qt/o arr #.0                                 ; /o refinement for options
        3         7        20        55       148       403      1097
     2981      8103     22026     59874    162755    442413   1202604
  3269017   8886111  24154953  65659969 178482301 485165195

>> qt/o arr #.2.1
2.72E+000 7.39E+000 2.01E+001 5.46E+001 1.48E+002 4.03E+002 1.10E+003
2.98E+003 8.10E+003 2.20E+004 5.99E+004 1.63E+005 4.42E+005 1.20E+006
3.27E+006 8.89E+006 2.42E+007 6.57E+007 1.78E+008 4.85E+008

>> arr: copy [] repeat x 26 [append arr x * x - 1e-5]
== [0.99999 3.99999 8.99999 15.99999 24.99999 35.99999 48.99999 63.99999 ...

>> qt arr                               ; automatic rounding to integer
  1   4   9  16  25  36  49  64  81 100 121 144 169 196 225 256 289 324 361
400 441 484 529 576 625 676

>> qt system
self     version  build    product  words    options  user     script
console  ports    network  schemes  error    standard

>> right-margin: 50
== 50
>> qt system
self     version  build    product  words
options  user     script   console  ports
network  schemes  error    standard

>> s: "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
>> arr: copy [] repeat x 12 [append arr s]
== ["ABCDEFGHIJKLMNOPQRSTUVWXYZ" "ABCDEFGHIJKLMNOPQRSTUVWXYZ" ...

>> qt arr                     ; long values truncated by default 3 to a line
ABCDEFGHIJKLMNOP ABCDEFGHIJKLMNOP ABCDEFGHIJKLMNOP
ABCDEFGHIJKLMNOP ABCDEFGHIJKLMNOP ABCDEFGHIJKLMNOP
ABCDEFGHIJKLMNOP ABCDEFGHIJKLMNOP ABCDEFGHIJKLMNOP
ABCDEFGHIJKLMNOP ABCDEFGHIJKLMNOP ABCDEFGHIJKLMNOP

>> qt/o arr #0.0.0             ; no truncation
ABCDEFGHIJKLMNOPQRSTUVWXYZ
ABCDEFGHIJKLMNOPQRSTUVWXYZ
ABCDEFGHIJKLMNOPQRSTUVWXYZ
.....

>> qt/o arr #5.0.4             ; truncation to five characters
VWXYZ VWXYZ VWXYZ VWXYZ VWXYZ VWXYZ VWXYZ VWXYZ
VWXYZ VWXYZ VWXYZ VWXYZ

>> qt/o arr #5.0.6             ; ... plus auto-justification
ABCDE ABCDE ABCDE ABCDE ABCDE ABCDE ABCDE ABCDE
ABCDE ABCDE ABCDE ABCDE
}

qt: func [
    {Quick table: prints out a simple block in aligned columns}
    b [any-block! object!]
    /o   options [block! any-string!]
    /local s rm width decimal out tmp-options max-width extra-width pad
][

    if object? b [
        b: first b
    ]
    rm: either value? 'right-margin [right-margin][77]
    if not options [
        either find b money! [
            options: #0.2.6
        ][
            options: #0.0.6
            if find b decimal! [
                foreach a b [
                    if all [decimal? :a not zero? a] [
                        if 10 < log-10 abs a [
                            options: #0.4.7 break  ; use scientific
                        ]
                        if 1e-4 < ((abs a) + 5e-5 // 1) [ ; if significantly
                            options: #0.4.6      ; different from an integer
                        ]
                    ]
                ]
        ]
        ]
    ]
    set [width decimal tmp-options extra-width]
        parse-integers/def options [0 0 6 0]
    extra-width: extra-width + 1
    options: to issue! rejoin [ width "." decimal "." tmp-options ]
    if zero? width [
        max-width: to integer! rm + extra-width / 3 - extra-width
        foreach a b [
            if not data-block? :a [
                width: maximum width  length? format :a options
            ]
            if width >= max-width [
                width: max-width
                break
            ]
        ]
    ]
    pad: head insert/dup copy "" " " extra-width
    s: 0
    options: to issue! rejoin [ width "." decimal "." tmp-options ]
    foreach a b [
        either data-block? :a [
            print "^/(nested)"
            qt/o a options
            s: 0
        ][
            s: s + length? out: format :a options
            if s > rm [
                print ""
                s: length? out
            ]
            prin out
            s: s + extra-width
            if positive? rm - s - extra-width [
                prin pad
            ]
        ]
    ]
    print ""
    exit
]

comment {      ================ QC ================

EXAMPLES:

>> arr: compose/deep [
[    ["pi" (pi)]
[    ["pi * pi" (pi * pi)]
[    ["exp pi" (exp pi)]
[    ["log-e pi" (log-e pi)]]
== [["pi" 3.14159265358979] ["pi * pi" 9.86960440108936] ["exp pi" ...

>> qc arr
pi        3.14
pi * pi   9.87
exp pi   23.14
log-e pi  1.14

>> qc arr #.4                    ; with optional options argument
pi        3.1416
pi * pi   9.8696
exp pi   23.1407
log-e pi  1.1447

>> qc arr #.4.2.2                ; two extra spaces
pi            3.1416
pi * pi       9.8696
exp pi       23.1407
log-e pi      1.1447

>> qc arr [#-10 #6.2]            ; passing block of options to FORMAT
pi           3.14
pi * pi      9.87
exp pi      23.14
log-e pi     1.14
}

unset!: (type?)

qc: func [
    {prints out nested blocks in aligned columns}
    b [any-block!]
    options [block! any-string! unset!] "optional options"
    /local  widths w max-width decimal tmp-options extra-width bb
][

    if not value? 'options [
       options: #20.2.6
    ]
    if not any-block? first b [
        qt/o b options
        exit
    ]
    if data-block? first first b [
        foreach a b [
            either value? 'options [qc a options][qc a]
            print ""
        ]
        exit
    ]
    if not block? options [
        set [max-width decimal tmp-options extra-width]
            parse-integers/def options [20 2 6 0]
        if zero? max-width [max-width: 20]
        options: to issue! rejoin [ 0 "." decimal "." tmp-options ]
        widths: array/initial length? b/1 4
        foreach bb b [
            while [(length? widths) < (length? :bb)] [
                append widths 4
            ]
            while [ not tail? :bb ] [
                w: minimum
                    maximum
                        length? format first :bb options
                        first widths
                    max-width
                if w > first widths [
                    change widths w
                ]
                bb: next :bb
                widths: next widths
            ]
            widths: head widths
        ]
        while [ not tail? widths ] [
            change widths to issue! rejoin [
                extra-width + first widths "."
                decimal "."
                tmp-options
            ]
            widths: next widths
        ]
        options: head widths
    ]
    foreach bb b [
        print format :bb options
    ]
]

comment {      ================ PARSE-INTEGERS ================

NOTE: Used by FORMAT, QT and QC to parse the options argument.
      Any datatype formable to a sequence of periods and integers
      may be used.

EXAMPLES:

>> parse-integers #20.3.-4
== [20 3 -4]
>> parse-integers 2.18
== [2 18]
>> parse-integers 2.100           ; trailing zeroes disappear when
== [2 1]                          ; decimal is formed
>> parse-integers #4....6
== [4 0 0 0 6]                    ; zero is default

>> parse-integers/def #4....6 [11 12 13 14 15 16 17 18 19 20]
== [4 12 13 14 6 16 17 18 19 20]
>> parse-integers/def 4....6 [11 12 13 14 15 16 17 18 19 20]
== [4 0 0 0 6 16 17 18 19 20]     ; zeroes appear when tuple is formed
}

parse-integers: func [
    {parse integers from the form of S}
    s
    /def defaults [block!]  "block of default values"
    /local item
][
    defaults: copy either def [defaults][[]]
    s: parse form s "."
    while [ not tail? s ] [
        defaults: either integer? item: load first s [
            either tail? defaults [
                insert tail defaults item
            ][
                change defaults item
            ]
        ][
            either tail? defaults [
                insert tail defaults 0
            ][
                next defaults
            ]
        ]
        s: next s
    ]
    head defaults
]

comment {      ================ DATA-BLOCK? ================

NOTE: Used by FORMAT, QT and QC

}
data-block?: func [
    {Returns TRUE if VALUE is a block, list, hash, paren or object}
    value [any-type!]
][
    all [
        value? 'value
        any [
            block? :value
            list? :value
            hash? :value
            paren? :value
            object? :value
        ]
    ]
]

comment {      ================ FULL-FORM ================

EXAMPLES:

>> form pi
== "3.14159265358979"
>> full-form pi
== "3.141592653589793"             ; forms to full precision

>> pi - to-decimal form pi
== 3.10862446895044E-15            ; cannot recover original value
>> pi - to-decimal full-form pi
== 0                               ; original value restored

>> full-form 2 ** 53 - 1
== "9007199254740991"
>> full-form 2 ** 53
== "9007199254740992"              ; greatest "integer"
>> full-form 2 ** 53 + 2
== "9.007199254740994E+15"         ; higher values in scientific notation

>> full-form 2 ** -1074            ; smallest positive decimal value
== "4.94065645841247E-324"         ; (excess precision here)
}

full-form: func [
    {returns full-precision form of number}
    n [number!]
    /local
    s digit exponent sign formed
    first-n diff form-it savs f-exp too-big big-int
][
    sign: either negative? n           ; save sign as string and
        [n: (- n) "-"][""]             ; make N positive

    too-big: positive? n - 1.79769313486231E+308   ; highest FORM-able number

    big-int: all [                     ; pseudo-integer, incrementable
        not negative? n - 1E+15        ; by 1, but FORM converts it to
        not positive? n - (2 ** 53)    ; scientific format
    ]

    if all [
        not big-int         ; always take control from 1E+15 to MAXINTEGER
        not too-big         ; if TOO-BIG, TO DECIMAL! FORM N overflows
        zero? n - to decimal! form n   ; otherwise if FORM is good enough
    ][return head insert form n sign]  ; ... use it

    first-n: n
    s: copy ""

    exponent: either any [
        positive? exponent: log-10 n   ; get rough value of exponent
        zero? exponent - (to integer! exponent)
    ][                                 ; get integer at or below rough value
        to integer! exponent
    ][
        -1 + to integer! exponent
    ]

    n: n / (10 ** exponent)    ; convert N so that  (N >= 1)  and  (N < 10)
    digit: to integer! n       ; get the integer portion

    if zero? digit [           ; in case LOG-10 rounded up to next integer,
        exponent: exponent - 1           ; making (N < 1) ...
        digit: to integer! n: n * 10     ; adjust and recalculate
    ]

    loop 16 [
        insert tail s digit                   ; append integer portion to N
        n: n - digit * 10                     ; increment N by factor of 10
        digit: to integer! n                  ; to get next integer portion
    ]

    insert next s "."        ; add decimal point to get representation of N

    f-exp: either negative? exponent [head insert form exponent "E" ][
        either positive? exponent                   ; make exponent string
            [head insert form exponent "E+"][""]
    ]
    form-it: func [][
        formed: copy f-exp               ; tack on exponent string to get
        insert formed s                  ; decimal representation of FIRST-N
        first-n - to decimal! formed     ; return the value for DIFF
    ]

    if not zero? diff: form-it [         ; if 16 loops didn't work ...
        savs: s
        if not too-big [
            s: string-add s "1"          ; first try incrementing,
            diff: form-it
        ]
        if not zero? diff [              ; and if that didn't work ...
            s: savs
            insert tail s digit          ; tack on 17th digit
        ]
    ]
    if zero? diff [                      ; return if we had the exact form
        return head insert  either big-int [
            head remove skip s 1         ; without decimal point if possible
        ][formed]           sign
    ]

    either positive? diff: form-it [     ; now see where we are
        while [ positive? diff ] [       ; increment till it works ...
            s: string-add s "1"
            diff: do form-it
        ]
    ][
        while [ negative? diff ] [       ; or decrement ...
            s: string-subtract/full-length s "1"
            diff: form-it
        ]
    ]
    head insert formed sign
]

comment {      ================ STRING-ADD ================

NOTE: Used by FULL-FORM

EXAMPLES:

>> string-add "123456789999999999875" "125"
== "123456790000000000000"

>> string-add "2.0000000000000000" "-125"
== "1.9999999999999875"              ; decimal point in longer arg ignored
}

string-add: func [
    {add two string representations of integers numerically -
    NOTE: decimal points in longer argument are ignored}
    a [string!] b [string!]
    /local c d neg
][
    a: copy a   b: copy b
    either #"-" = first a [
        either #"-" = first b [neg: true remove a remove b][
            remove a  return string-subtract b a
        ]
    ][
        if #"-" = first b [remove b  return string-subtract a b]
    ]
    if (length? a) < (length? b) [set [a b] reduce [b a]]
    insert/dup b "0" (length? a) - (length? b)
    a: tail a  b: tail b
    d: 0 while [ not head? b ] [
        a: back a  b: back b
        if #"." = first a [a: back a]
        c: (first a) + (first b) + d - 48
        d: either c > #"9" [c: c - 10  1][0]
        change a c
    ]
    if d > 0 [insert a "1"]
    if neg [insert a "-"]
    a
]

comment {      ================ STRING-SUBTRACT ================

NOTE: Used by FULL-FORM
}

string-subtract: func [
    {subtract two string representations of integers numerically -
    NOTE: decimal points in longer argument are ignored}
    a [string!] b [string!]
    /full-length
    /local c d neg
][
    a: copy a   b: copy b
    either #"-" = first a [
        either #"-" = first b [neg: true  remove a remove b][
            insert b "-"   return string-add a b
        ]
    ][
        if #"-" = first b [remove b  return string-add a b]
    ]
    if any [
        (length? a) < (length? b)
        all [(length? a) = (length? b)  a < b]
    ][set [a b] reduce [b a]  neg: not neg]
    insert/dup b "0" (length? a) - (length? b)
    a: tail a  b: tail b
    d: 0 while [ not head? b ] [
        a: back a  b: back b
        if #"." = first a [a: back a]
        c: to char! (first a) - (first b) - d + 48
        d: either c < #"0" [c: c + 10   1][0]
        change a c
    ]
    if not full-length [
        while [all [#"0" = first a  1 < length? a]][remove a]
    ]
    if neg [
        either #"-" = first a [remove a][insert a "-"]
    ]
    a
]

comment {      ================ PAREN-FORM ================

NOTE: This is the  fastest way to make a precise string representation
      of an arbitrary decimal

EXAMPLE:

>> paren-form pi
== "(3.14159265358979 + 3.10862446895044E-15)"
>> pi - do paren-form pi
== 0
}

paren-form: func [
    {returns a string precisely representing numerical value}
    n [number!]
    /local s diff
][
    diff: n - to decimal! s: form n
    either zero? diff [s][to string! reduce ["(" s " + " diff ")"]]
]


                                   CCHHAAPPTTEERR  88

                        FFuunnccttiioonnss,, FFcclloossuurreess,, aanndd MMaaccrrooss

             88..11..  vvaalliidd ffuunnccttiioonn oobbjjeeccttss

                     There are many different objects which can occupy
                the function field of a symbol object.  Table 8.1,  on
                the  following  page,  shows all of the possibilities,
                how to recognize them, and where to look for  documen-
                tation.

             88..22..  ffuunnccttiioonnss

                     The  basic  Lisp function is the lambda function.
                When a lambda function is called, the actual arguments
                are  evaluated from left to right and are lambda-bound
                to the formal parameters of the lambda function.

                     An nlambda function is usually used for functions
                which  are  invoked  by  the  user at top level.  Some
                built-in functions which evaluate their  arguments  in
                special  ways  are  also  nlambdas (e.g _c_o_n_d, _d_o, _o_r).
                When an  nlambda  function  is  called,  the  list  of
                unevaluated  arguments  is  lambda bound to the single
                formal parameter of the nlambda function.

                     Some programmers will  use  an  nlambda  function
                when  they  are  not  sure  how many arguments will be
                passed.  Then, the first thing  the  nlambda  function
                does  is  map  _e_v_a_l over the list of unevaluated argu-
                ments it has been passed.  This is usually  the  wrong
                thing  to  do,  as it will not work compiled if any of
                the arguments are local variables.  The solution is to
                use  a  lexpr.   When  a lexpr function is called, the
                arguments are evaluated and a fixnum  whose  value  is
                the  number of arguments is lambda-bound to the single
                formal parameter of the lexpr function.  The lexpr can
                then access the arguments using the _a_r_g function.

                     When a function is compiled, _s_p_e_c_i_a_l declarations
                may be needed to preserve its behavior.   An  argument
                is  not  lambda-bound to the name of the corresponding
                formal parameter unless that formal parameter has been

          FFuunnccttiioonnss,, FFcclloossuurreess,, aanndd MMaaccrrooss                         88--11

          FFuunnccttiioonnss,, FFcclloossuurreess,, aanndd MMaaccrrooss                         88--22

          +-------------------+------------------------+----------------+
          |  informal name    |      object type       | documentation  |
          +-------------------+------------------------+----------------+
          |   interpreted     |     list with _c_a_r      |      8.2       |
          | lambda function   |      _e_q to lambda      |                |
          +-------------------+------------------------+----------------+
          |   interpreted     |     list with _c_a_r      |      8.2       |
          | nlambda function  |     _e_q to nlambda      |                |
          +-------------------+------------------------+----------------+
          |   interpreted     |     list with _c_a_r      |      8.2       |
          |  lexpr function   |      _e_q to lexpr       |                |
          +-------------------+------------------------+----------------+
          |   interpreted     |     list with _c_a_r      |      8.3       |
          |      macro        |      _e_q to macro       |                |
          +-------------------+------------------------+----------------+
          |     fclosure      |   vector with _v_p_r_o_p    |      8.4       |
          |                   |     _e_q to fclosure     |                |
          +-------------------+------------------------+----------------+
          |     compiled      | binary with discipline |      8.2       |
          | lambda or lexpr   |      _e_q to lambda      |                |
          |     function      |                        |                |
          +-------------------+------------------------+----------------+
          |     compiled      | binary with discipline |      8.2       |
          | nlambda function  |     _e_q to nlambda      |                |
          +-------------------+------------------------+----------------+
          |     compiled      | binary with discipline |      8.3       |
          |      macro        |      _e_q to macro       |                |
          +-------------------+------------------------+----------------+
          |     foreign       | binary with discipline |      8.5       |
          +-----s-u-b-r-o-uo-tf-i-n"-es-u-b-r-o-u+t-i-n-e-"-.-n-r--3-b-o-t--1-2-4-0->-?-1-2-4-0-+----------------+
          |     foreign       | binary with discipline |      8.5       |
          +------f-u-n-c-t-i-oo-nf--"-f-u-n-c+t-i-o-n-"-.-n-r--3-b-o-t--1-3-2-0->-?-1-3-2-0-+----------------+
          |     foreign       | binary with discipline |      8.5       |
          +--i-n-to-ef-g-e"-ri-n-ft-ue-ng-ce-tr-i--of-nu-n-c+t-i-o-n-"-.-n-r--3-b-o-t--1-4-0-0->-?-1-4-0-0-+----------------+
          |     foreign       | binary with discipline |      8.5       |
          +---r-e-a-l-o-ff-u-n"-cr-te-ia-ol-n--f-u-n-c+t-i-o-n-"-.-n-r--3-b-o-t--1-4-8-0->-?-1-4-8-0-+----------------+
          |     foreign       | binary with discipline |      8.5       |
          +-----C--f-u-n-co-tf-i-o"-nc---f-u-n-c+t-i-o-n-"-.-n-r--3-b-o-t--1-5-6-0->-?-1-5-6-0-+----------------+
          |     foreign       | binary with discipline |      8.5       |
          +--d-oo-uf-b-l"-ed-o-fu-ub-nl-ce-t--ic-o--nf-u-n-c+t-i-o-n-"-.-n-r--3-b-o-t--1-6-4-0->-?-1-6-4-0-+----------------+
          |     foreign       | binary with discipline |      8.5       |
          +-s-t-ro-uf-c-t"-uv-re-ec-t-fo-ur-n--cc-t--if-ou-nn-c+t-i-o-n-"-.-n-r--3-b-o-t--1-7-2-0->-?-1-7-2-0-+----------------+
          |      array        |      array object      |       9        |
          +-------------------+------------------------+----------------+
                                    Table 8.1

                                             Printed: October 16, 1993

          FFuunnccttiioonnss,, FFcclloossuurreess,, aanndd MMaaccrrooss                         88--33

                declared _s_p_e_c_i_a_l (see S12.3.2.2).

                     Lambda and lexpr functions both  compile  into  a
                binary object with a discipline of lambda.  However, a
                compiled lexpr still acts like an interpreted lexpr.

             88..33..  mmaaccrrooss

                     An important feature of Lisp is  its  ability  to
                manipulate  programs  as  data.   As a result of this,
                most Lisp implementations  have  very  powerful  macro
                facilities.  The Lisp language's macro facility can be
                used to incorporate popular features of the other lan-
                guages  into Lisp.  For example, there are macro pack-
                ages which allow one to create  records  (ala  Pascal)
                and  refer  to  elements of those records by the field
                names.  The _s_t_r_u_c_t package imported from Maclisp  does
                this.   Another  popular  use  for macros is to create
                more readable control  structures  which  expand  into
                _c_o_n_d,  _o_r  and _a_n_d.  One such example is the If macro.
                It allows you to write

                _(_I_f _(_e_q_u_a_l _n_u_m_b _0_) _t_h_e_n _(_p_r_i_n_t _'_z_e_r_o_) _(_t_e_r_p_r_)
                 _e_l_s_e_i_f _(_e_q_u_a_l _n_u_m_b _1_) _t_h_e_n _(_p_r_i_n_t _'_o_n_e_) _(_t_e_r_p_r_)
                 _e_l_s_e _(_p_r_i_n_t _'_|_I _g_i_v_e _u_p_|_)_)

                which expands to

                _(_c_o_n_d
                    _(_(_e_q_u_a_l _n_u_m_b _0_) _(_p_r_i_n_t _'_z_e_r_o_) _(_t_e_r_p_r_)_)
                    _(_(_e_q_u_a_l _n_u_m_b _1_) _(_p_r_i_n_t _'_o_n_e_) _(_t_e_r_p_r_)_)
                    _(_t _(_p_r_i_n_t _'_|_I _g_i_v_e _u_p_|_)_)_)

                88..33..11..  mmaaccrroo ffoorrmmss

                        A macro is a function  which  accepts  a  Lisp
                   expression   as  input  and  returns  another  Lisp
                   expression.  The action the macro takes  is  called
                   macro expansion.  Here is a simple example:

                   -> _(_d_e_f _f_i_r_s_t _(_m_a_c_r_o _(_x_) _(_c_o_n_s _'_c_a_r _(_c_d_r _x_)_)_)_)
                   first
                   -> _(_f_i_r_s_t _'_(_a _b _c_)_)
                   a
          ____________________
             tthhee ffiirrsstt cchhaarraacctteerr ooff tthhee ssttrriinngg iiss ssiiggnniiffiiccaanntt ((ii..ee ""ss""
          iiss ookk ffoorr ""ssuubbrroouuttiinnee""))

                                             Printed: October 16, 1993

          FFuunnccttiioonnss,, FFcclloossuurreess,, aanndd MMaaccrrooss                         88--44

                   -> _(_a_p_p_l_y _'_f_i_r_s_t _'_(_f_i_r_s_t _'_(_a _b _c_)_)_)
                   (car '(a b c))

                   The  first input line defines a macro called _f_i_r_s_t.
                   Notice that the macro has one formal parameter,  _x.
                   On the second input line, we ask the interpreter to
                   evaluate _(_f_i_r_s_t _'_(_a _b _c_)_).  _E_v_a_l  sees  that  _f_i_r_s_t
                   has  a  function  definition  of  type macro, so it
                   evaluates _f_i_r_s_t's definition, passing to _f_i_r_s_t,  as
                   an  argument,  the  form  _e_v_a_l itself was trying to
                   evaluate: _(_f_i_r_s_t _'_(_a _b _c_)_).  The _f_i_r_s_t macro  chops
                   off  the  car of the argument with _c_d_r, cons' a _c_a_r
                   at  the  beginning  of   the   list   and   returns
                   _(_c_a_r _'_(_a _b _c_)_),  which _e_v_a_l evaluates.  The value _a
                   is returned as the value of _(_f_i_r_s_t _'_(_a _b _c_)_).  Thus
                   whenever  _e_v_a_l  tries  to evaluate a list whose car
                   has a macro definition it ends up doing (at  least)
                   two operations, the first of which is a call to the
                   macro to let it macro  expand  the  form,  and  the
                   other is the evaluation of the result of the macro.
                   The result of the macro may be yet another call  to
                   a  macro,  so _e_v_a_l may have to do even more evalua-
                   tions until it can finally determine the  value  of
                   an  expression.   One  way  to see how a macro will
                   expand is to use _a_p_p_l_y as shown on the third  input
                   line above.

                88..33..22..  ddeeffmmaaccrroo

                        The  macro  _d_e_f_m_a_c_r_o makes it easier to define
                   macros because it allows you to name the  arguments
                   to  the  macro  call.  For example, suppose we find
                   ourselves     often     writing      code      like
                   _(_s_e_t_q _s_t_a_c_k _(_c_o_n_s _n_e_w_e_l_t _s_t_a_c_k_).  We could define a
                   macro named _p_u_s_h to do this for  us.   One  way  to
                   define it is:

                   -> _(_d_e_f _p_u_s_h
                         _(_m_a_c_r_o _(_x_) _(_l_i_s_t _'_s_e_t_q _(_c_a_d_d_r _x_) _(_l_i_s_t _'_c_o_n_s _(_c_a_d_r _x_) _(_c_a_d_d_r _x_)_)_)_)_)
                   push

                   then  _(_p_u_s_h _n_e_w_e_l_t _s_t_a_c_k_)  will  expand to the form
                   mentioned above.  The same macro written using def-
                   macro would be:

                   -> _(_d_e_f_m_a_c_r_o _p_u_s_h _(_v_a_l_u_e _s_t_a_c_k_)
                       _(_l_i_s_t _'_s_e_t_q _,_s_t_a_c_k _(_l_i_s_t _'_c_o_n_s _,_v_a_l_u_e _,_s_t_a_c_k_)_)_)
                   push

                   Defmacro  allows  you  to name the arguments of the
                   macro call, and makes  the  macro  definition  look

                                             Printed: October 16, 1993

          FFuunnccttiioonnss,, FFcclloossuurreess,, aanndd MMaaccrrooss                         88--55

                   more like a function definition.

                88..33..33..  tthhee bbaacckkqquuoottee cchhaarraacctteerr mmaaccrroo

                        The  default  syntax  for  FRANZ LISP has four
                   characters with associated character  macros.   One
                   is  semicolon  for  comments.   Two  others are the
                   backquote and comma which are used by the backquote
                   character  macro.   The  fourth  is  the sharp sign
                   macro described in the next section.

                        The backquote macro is used  to  create  lists
                   where  many  of  the  elements  are fixed (quoted).
                   This makes it very useful for creating macro  defi-
                   nitions.   In  the  simplest case, a backquote acts
                   just like a single quote:

                   ->_`_(_a _b _c _d _e_)
                   (a b c d e)

                   If a comma precedes an element of a backquoted list
                   then that element is evaluated and its value is put
                   in the list.

                   ->_(_s_e_t_q _d _'_(_x _y _z_)_)
                   (x y z)
                   ->_`_(_a _b _c _,_d _e_)
                   (a b c (x y z) e)

                   If a comma followed by an at sign precedes an  ele-
                   ment  in  a  backquoted  list, then that element is
                   evaluated and spliced into the list with _a_p_p_e_n_d.

                   ->_`_(_a _b _c _,_@_d _e_)
                   (a b c x y z e)

                   Once a list begins with a backquote, the commas may
                   appear anywhere in the list as this example shows:

                   ->_`_(_a _b _(_c _d _,_(_c_d_r _d_)_) _(_e _f _(_g _h _,_@_(_c_d_d_r _d_) _,_@_d_)_)_)
                   (a b (c d (y z)) (e f (g h z x y z)))

                   It  is  also  possible and sometimes even useful to
                   use the backquote macro within itself.  As a  final
                   demonstration  of  the  backquote  macro,  we shall
                   define the first and  push  macros  using  all  the
                   power  at  our disposal: defmacro and the backquote
                   macro.

                   ->_(_d_e_f_m_a_c_r_o _f_i_r_s_t _(_l_i_s_t_) _`_(_c_a_r _,_l_i_s_t_)_)
                   first

                                             Printed: October 16, 1993

          FFuunnccttiioonnss,, FFcclloossuurreess,, aanndd MMaaccrrooss                         88--66

                   ->_(_d_e_f_m_a_c_r_o _p_u_s_h _(_v_a_l_u_e _s_t_a_c_k_) _`_(_s_e_t_q _,_s_t_a_c_k _(_c_o_n_s _,_v_a_l_u_e _,_s_t_a_c_k_)_)_)
                   stack

                88..33..44..  sshhaarrpp ssiiggnn cchhaarraacctteerr mmaaccrroo

                        The sharp sign macro can perform a  number  of
                   different  functions   at read time.  The character
                   directly following the sharp sign determines  which
                   function  will  be  done,  and  following  Lisp  s-
                   expressions may serve as arguments.

                   88..33..44..11..  ccoonnddiittiioonnaall iinncclluussiioonn

                      If you plan to run one source file in more  than
                      one environment then you may want to some pieces
                      of code to be included  or not included  depend-
                      ing  on  the  environment.   The C language uses
                      "#ifdef" and "#ifndef"  for  this  purpose,  and
                      Lisp  uses  "#+" and "#-".  The environment that
                      the sharp sign macro checks is the  _(_s_t_a_t_u_s _f_e_a_-
                      _t_u_r_e_s_)  list  which is initialized when the Lisp
                      system is built  and which may  be   altered  by
                      _(_s_s_t_a_t_u_s _f_e_a_t_u_r_e _f_o_o_)                        and
                      _(_s_s_t_a_t_u_s _n_o_f_e_a_t_u_r_e _b_a_r_) The form  of conditional
                      inclusion is
                                   _#_+_w_h_e_n _w_h_a_t
                      where  _w_h_e_n  is either a symbol or an expression
                      involving symbols and the functions _a_n_d, _o_r, and
                      _n_o_t.  The meaning is that _w_h_a_t will only be read
                      in if _w_h_e_n is true.  A symbol in  _w_h_e_n  is  true
                      only  if  it  appears  in  the _(_s_t_a_t_u_s _f_e_a_t_u_r_e_s_)
                      list.

                                             Printed: October 16, 1993

          FFuunnccttiioonnss,, FFcclloossuurreess,, aanndd MMaaccrrooss                         88--77

              ____________________________________________________

              ; suppose we want to write a program which references a file
              ; and which can run at ucb, ucsd and cmu where the file naming conventions
              ; are different.
              ;
              -> _(_d_e_f_u_n _h_o_w_o_l_d _(_n_a_m_e_)
                       _(_t_e_r_p_r_)
                          _(_l_o_a_d _#_+_(_o_r _u_c_b _u_c_s_d_) _"_/_u_s_r_/_l_i_b_/_l_i_s_p_/_a_g_e_s_._l_"
                                           _#_+_c_m_u _"_/_u_s_r_/_l_i_s_p_/_d_o_c_/_a_g_e_s_._l_"_)
                             _(_p_a_t_o_m _n_a_m_e_)
                             _(_p_a_t_o_m _" _i_s _"_)
                                _(_p_r_i_n_t _(_c_d_r _(_a_s_s_o_c _n_a_m_e _a_g_e_f_i_l_e_)_)_)
                                   _(_p_a_t_o_m _"_y_e_a_r_s _o_l_d_"_)
                                      _(_t_e_r_p_r_)_)
              ____________________________________________________

          The form
                                   _#_-_w_h_e_n _w_h_a_t
          is equivalent to
                                _#_+_(_n_o_t _w_h_e_n_) _w_h_a_t

                   88..33..44..22..  ffiixxnnuumm cchhaarraacctteerr eeqquuiivvaalleennttss

                      When working with fixnum equivalents of  charac-
                      ters,  it  is  often hard to remember the number
                      corresponding to a character.  The form
                                       _#_/_c
                      is equivalent to the  fixnum  representation  of
                      character c.

              ____________________________________________________

              ; a function which returns t if the user types y else it returns nil.
              ;
              -> _(_d_e_f_u_n _y_e_s_o_r_n_o _n_i_l
                       _(_p_r_o_g_n _(_a_n_s_)
                                        _(_s_e_t_q _a_n_s _(_t_y_i_)_)
                                                  _(_c_o_n_d _(_(_e_q_u_a_l _a_n_s _#_/_y_) _t_)
                                                                        _(_t _n_i_l_)_)_)_)
              ____________________________________________________

                                             Printed: October 16, 1993

          FFuunnccttiioonnss,, FFcclloossuurreess,, aanndd MMaaccrrooss                         88--88

                   88..33..44..33..  rreeaadd ttiimmee eevvaalluuaattiioonn

                      Occasionally you want to express a constant as a
                      Lisp expression, yet you don't want to  pay  the
                      penalty  of evaluating this expression each time
                      it is referenced.  The form
                                  _#_._e_x_p_r_e_s_s_i_o_n
                      evaluates  the  expression  at  read  time   and
                      returns its value.

              ____________________________________________________

              ; a function to test if any of bits 1 3 or 12 are set in a fixnum.
              ;
              -> _(_d_e_f_u_n _t_e_s_t_i_t _(_n_u_m_)
                       _(_c_o_n_d _(_(_z_e_r_o_p _(_b_o_o_l_e _1 _n_u_m _#_._(_+ _(_l_s_h _1 _1_) _(_l_s_h _1 _3_) _(_l_s_h _1 _1_2_)_)_)_)
                                        _n_i_l_)
                                      _(_t _t_)_)_)
              ____________________________________________________

             88..44..  ffcclloossuurreess

                     Fclosures  are  a type of functional object.  The
                purpose is to remember the values  of  some  variables
                between  invocations  of  the functional object and to
                protect this data from being inadvertently overwritten
                by  other  Lisp  functions.   Fortran programs usually
                exhibit this behavior for their variables.  (In  fact,
                some  versions  of Fortran would require the variables
                to be in COMMON).  Thus it is easy to write  a  linear
                congruent  random  number generator in Fortran, merely
                by keeping the seed as a variable in the function.  It
                is much more risky to do so in Lisp, since any special
                variable you picked, might be used by some other func-
                tion.  Fclosures are an attempt to provide most of the
                same functionality as closures in Lisp  Machine  Lisp,
                to users of FRANZ LISP.  Fclosures are related to clo-
                sures in this way:
                (fclosure '(a b) 'foo) <==>
                     (let ((a a) (b b)) (closure '(a b) 'foo))

                88..44..11..  aann eexxaammppllee

          ____________________________________________________________

                                             Printed: October 16, 1993

          FFuunnccttiioonnss,, FFcclloossuurreess,, aanndd MMaaccrrooss                         88--99

          % lliisspp
          Franz Lisp, Opus 38.60
          ->((ddeeffuunn ccooddee ((mmee ccoouunntt))
            ((pprriinntt ((lliisstt ''iinn xx))))
            ((sseettqq xx ((++ 11 xx))))
            ((ccoonndd ((((ggrreeaatteerrpp ccoouunntt 11)) ((ffuunnccaallll mmee mmee ((ssuubb11 ccoouunntt))))))))
            ((pprriinntt ((lliisstt ''oouutt xx))))))
          code
          ->((ddeeffuunn tteesstteerr ((oobbjjeecctt ccoouunntt))
            ((ffuunnccaallll oobbjjeecctt oobbjjeecctt ccoouunntt)) ((tteerrpprrii))))
          tester
          ->((sseettqq xx 00))
          0
          ->((sseettqq zz ((ffcclloossuurree ''((xx)) ''ccooddee))))
          fclosure[8]
          -> ((tteesstteerr zz 33))
          (in 0)(in 1)(in 2)(out 3)(out 3)(out 3)
          nil
          ->xx
          0
          ____________________________________________________________

                        The function _f_c_l_o_s_u_r_e  creates  a  new  object
                   that  we  will  call  an  fclosure, (although it is
                   actually a vector).  The fclosure contains a  func-
                   tional  object, and a set of symbols and values for
                   the symbols.  In the above  example,  the  fclosure
                   functional object is the function code.  The set of
                   symbols and values just contains the symbol `x' and
                   zero,  the  value of `x' when the fclosure was cre-
                   ated.

                   When an fclosure is funcall'ed:

                   1)   The Lisp system lambda binds  the  symbols  in
                        the  fclosure to their values in the fclosure.

                   2)   It continues the  funcall  on  the  functional
                        object of the fclosure.

                   3)   Finally, it un-lambda binds the symbols in the
                        fclosure and at the same time stores the  cur-
                        rent values of the symbols in the fclosure.

                        Notice  that  the fclosure is saving the value
                   of the symbol `x'.  Each time a  fclosure  is  cre-
                   ated,  new space is allocated for saving the values
                   of the symbols. Thus if we execute fclosure  again,

                                             Printed: October 16, 1993

          FFuunnccttiioonnss,, FFcclloossuurreess,, aanndd MMaaccrrooss                        88--1100

                   over the same function, we can have two independent
                   counters:

          ____________________________________________________________

          -> ((sseettqq zzzz ((ffcclloossuurree ''((xx)) ''ccooddee))))
          fclosure[1]
          -> ((tteesstteerr zzzz 22))
          (in 0)(in 1)(out 2)(out 2)
          -> ((tteesstteerr zzzz 22))
          (in 2)(in 3)(out 4)(out 4)
          -> ((tteesstteerr zz 33))
          (in 3)(in 4)(in 5)(out 6)(out 6)(out 6)
          ____________________________________________________________

                88..44..22..  uusseeffuull ffuunnccttiioonnss

                        Here are some quick some  summaries  of  func-
                   tions  dealing  with  closures.  They are more for-
                   mally defined in S2.8.4.  To recap,  fclosures  are
                   made by _(_f_c_l_o_s_u_r_e _'_l___v_a_r_s _'_g___f_u_n_c_o_b_j_).  l_vars is a
                   list of symbols (not containing nil), g_funcobj  is
                   any  object  that can be funcalled.  (Objects which
                   can be funcalled, include compiled Lisp  functions,
                   lambda  expressions,  symbols,  foreign  functions,
                   etc.)  In general, if you want a compiled  function
                   to  be closed over a variable, you must declare the
                   variable  to  be  special  within   the   function.
                   Another example would be:

                               (fclosure '(a b) #'(lambda (x) (plus x a)))

                   Here,  the  #'  construction will make the compiler
                   compile the lambda expression.

                        There are times when you want to  share  vari-
                   ables  between  fclosures.  This can be done if the
                   fclosures are created at the same time using  _f_c_l_o_-
                   _s_u_r_e_-_l_i_s_t.   The function _f_c_l_o_s_u_r_e_-_a_l_i_s_t returns an
                   assoc list giving the symbols  and  values  in  the
                   fclosure.   The  predicate  _f_c_l_o_s_u_r_e_p returns t iff
                   its  argument  is  a  fclosure.   Other   functions
                   imported  from  Lisp  Machine  Lisp are _s_y_m_e_v_a_l_-_i_n_-
                   _f_c_l_o_s_u_r_e_,   _l_e_t_-_f_c_l_o_s_e_d_,    and    _s_e_t_-_i_n_-_f_c_l_o_s_u_r_e_.
                   Lastly,  the function _f_c_l_o_s_u_r_e_-_f_u_n_c_t_i_o_n returns the
                   function argument.

                                             Printed: October 16, 1993

          FFuunnccttiioonnss,, FFcclloossuurreess,, aanndd MMaaccrrooss                        88--1111

                88..44..33..  iinntteerrnnaall ssttrruuccttuurree

                        Currently, closures are  implemented  as  vec-
                   tors, with property being the symbol fclosure.  The
                   functional object is the first entry.  The  remain-
                   ing  entries are structures which point to the sym-
                   bols and values for the closure, (with a  reference
                   count  to  determine  if  a  recursive  closure  is
                   active).

             88..55..  ffoorreeiiggnn ssuubbrroouuttiinneess aanndd ffuunnccttiioonnss

                     FRANZ LISP has the ability  to  dynamically  load
                object  files  produced by other compilers and to call
                functions defined in those files.  These functions are
                called _f_o_r_e_i_g_n functions.*  There are seven  types  of
                foreign functions.  They are characterized by the type
                of result they  return,  and  by  differences  in  the
                interpretation of their arguments.  They come from two
                families: a group  suited  for  languages  which  pass
                arguments  by  reference  (e.g.  Fortran), and a group
                suited for languages which  pass  arguments  by  value
                (e.g. C).

                There are four types in the first group:

                ssuubbrroouuttiinnee
                     This  does  not return anything.  The Lisp system
                     always returns t after calling a subroutine.

                ffuunnccttiioonn
                     This returns whatever the function returns.  This
                     must  be  a valid Lisp object or it may cause the
                     Lisp system to fail.

                iinntteeggeerr--ffuunnccttiioonn
                     This returns an integer  which  the  Lisp  system
                     makes into a fixnum and returns.

                rreeaall--ffuunnccttiioonn
                     This returns a double precision real number which
                     the Lisp system makes into a flonum and  returns.

          ____________________
             *This  topic  is  also discussed in Report PAM-124 of the
          Center for  Pure  and  Applied  Mathematics,  UCB,  entitled
          ``Parlez-Vous  Franz?  An Informal Introduction to Interfac-
          ing Foreign Functions to Franz LISP'', by James R. Larus

                                             Printed: October 16, 1993

          FFuunnccttiioonnss,, FFcclloossuurreess,, aanndd MMaaccrrooss                        88--1122

                There are three types in the second group:

                cc--ffuunnccttiioonn
                     This  is like an integer function, except for its
                     different interpretation of arguments.

                ddoouubbllee--cc--ffuunnccttiioonn
                     This is like a real-function.

                vveeccttoorr--cc--ffuunnccttiioonn
                     This is for C functions which return a structure.
                     The  first  argument  to such functions must be a
                     vector (of type vectori), into which  the  result
                     is  stored.  The second Lisp argument becomes the
                     first argument to the C function, and so on

                A foreign function is accessed through a binary object
                just like a compiled Lisp function.  The difference is
                that the discipline field of a  binary  object  for  a
                foreign  function is a string whose first character is
                given in the following table:

                             +-------+-------------------+
                             |letter |       type        |
                             +-------+-------------------+
                             |  s    |    subroutine     |
                             +-------+-------------------+
                             |  f    |     function      |
                             +-------+-------------------+
                             |  i    | integer-function  |
                             +-------+-------------------+
                             |  r    |  real-function.   |
                             +-------+-------------------+
                             |  c    |    c-function     |
                             +-------+-------------------+
                             |  v    | vector-c-function |
                             +-------+-------------------+
                             |  d    | double-c-function |
                             +-------+-------------------+
                             +-------+-------------------+
                Two functions  are  provided  for  setting-up  foreign
                functions.   _C_f_a_s_l  loads an object file into the Lisp
                system and sets up one foreign function binary object.
                If there are more than one function in an object file,
                _g_e_t_a_d_d_r_e_s_s can be used to set  up  additional  foreign
                function objects.

                     Foreign   functions  are  called  just like other
                functions, e.g _(_f_u_n_n_a_m_e _a_r_g_1 _a_r_g_2_).  When  a  function
                in  the  Fortran  group  is  called, the arguments are
                evaluated and then examined.  List,  hunk  and  symbol

                                             Printed: October 16, 1993

          FFuunnccttiioonnss,, FFcclloossuurreess,, aanndd MMaaccrrooss                        88--1133

                arguments  are  passed  unchanged to the foreign func-
                tion.  Fixnum and flonum arguments are copied  into  a
                temporary  location  and  a  pointer  to  the value is
                passed (this is because Fortran uses call by reference
                and it is dangerous to modify the contents of a fixnum
                or flonum which something else might  point  to).   If
                the argument is an array object, the data field of the
                array object is passed to the foreign  function  (This
                is  the  easiest  way to send large amounts of data to
                and receive large amounts of data from a foreign func-
                tion).   If  a binary object is an argument, the entry
                field of that object is passed to the foreign function
                (the entry field is the address of a function, so this
                amounts to passing a function as an argument).

                     When a function in the C group is called,  fixnum
                and flownum arguments are passed by value.  For almost
                all other arguments, the address is merely provided to
                the  C  routine.   The  only exception arises when you
                want to invoke a C routine which  expects  a  ``struc-
                ture''  argument.  Recall that a (rarely used) feature
                of the C language is the ability to pass structures by
                value.   This  copies  the  structure  onto the stack.
                Since the Franz's nearest equivalent to a C  structure
                is  a  vector, we provide an escape clause to copy the
                contents of an immediate-type vector by value.  If the
                property  field  of  a vectori argument, is the symbol
                "value-structure-argument", then the  binary  data  of
                this immediate-type vector is copied into the argument
                list of the C routine.

                     The method a foreign function uses to access  the
                arguments  provided  by  Lisp is dependent on the lan-
                guage of the foreign function.  The following  scripts
                demonstrate  how how Lisp can interact with three lan-
                guages: C, Pascal and  Fortran.   C  and  Pascal  have
                pointer  types  and  the first script shows how to use
                pointers to extract  information  from  Lisp  objects.
                There  are  two  functions  defined for each language.
                The first (cfoo in C, pfoo in Pascal)  is  given  four
                arguments,  a  fixnum, a flonum-block array, a hunk of
                at least two fixnums  and  a  list  of  at  least  two
                fixnums.   To demonstrate that the values were passed,
                each ?foo function prints its arguments (or  parts  of
                them).   The  ?foo  function  then modifies the second
                element of the flonum-block array and returns a  3  to
                Lisp.   The second function (cmemq in C, pmemq in Pas-
                cal) acts just like the Lisp _m_e_m_q function (except  it
                won't work for fixnums whereas the lisp _m_e_m_q will work
                for small fixnums).  In the script, typed input is  in
                bboolldd,  computer output is in roman and comments are in
                _i_t_a_l_i_c_.

                                             Printed: October 16, 1993

          FFuunnccttiioonnss,, FFcclloossuurreess,, aanndd MMaaccrrooss                        88--1144

          ____________________________________________________________

          _T_h_e_s_e _a_r_e _t_h_e _C _c_o_d_e_d _f_u_n_c_t_i_o_n_s
          % ccaatt cchh88aauuxxcc..cc
          /* demonstration of c coded foreign integer-function */

          /* the following will be used to extract fixnums out of a list of fixnums */
          struct listoffixnumscell
          {    struct listoffixnumscell *cdr;
               int *fixnum;
          };

          struct listcell
          {       struct listcell *cdr;
                  int car;
          };

          cfoo(a,b,c,d)
          int *a;
          double b[];
          int *c[];
          struct listoffixnumscell *d;
          {
              printf("a: %d, b[0]: %f, b[1]: %f0, *a, b[0], b[1]);
              printf(" c (first): %d   c (second): %d0,
                         *c[0],*c[1]);
              printf(" ( %d %d ... )", *(d->fixnum), *(d->cdr->fixnum));
              b[1] = 3.1415926;
              return(3);
          }

          struct listcell *
          cmemq(element,list)
          int element;
          struct listcell *list;
          {
             for( ; list && element != list->car ;  list = list->cdr);
             return(list);
          }

          _T_h_e_s_e _a_r_e _t_h_e _P_a_s_c_a_l _c_o_d_e_d _f_u_n_c_t_i_o_n_s
          % ccaatt cchh88aauuxxpp..pp
          type    pinteger = ^integer;
                  realarray = array[0..10] of real;
                  pintarray = array[0..10] of pinteger;
                  listoffixnumscell = record
                                          cdr  : ^listoffixnumscell;
                                          fixnum : pinteger;
                                      end;
                  plistcell = ^listcell;
                  listcell = record
                                cdr : plistcell;

                                             Printed: October 16, 1993

          FFuunnccttiioonnss,, FFcclloossuurreess,, aanndd MMaaccrrooss                        88--1155

                                car : integer;
                             end;

          function pfoo ( var a : integer ;
                          var b : realarray;
                          var c : pintarray;
                          var d : listoffixnumscell) : integer;
          begin
             writeln(' a:',a, ' b[0]:', b[0], ' b[1]:', b[1]);
             writeln(' c (first):', c[0]^,' c (second):', c[1]^);
             writeln(' ( ', d.fixnum^, d.cdr^.fixnum^, ' ...) ');
             b[1] := 3.1415926;
             pfoo := 3
          end ;

          { the function pmemq looks for the Lisp pointer given as the first argument
            in the list pointed to by the second argument.
            Note that we declare " a : integer " instead of " var a : integer " since
            we are interested in the pointer value instead of what it points to (which
            could be any Lisp object)
          }
          function pmemq( a : integer; list : plistcell) : plistcell;
          begin
           while (list <> nil) and (list^.car <> a) do list := list^.cdr;
           pmemq := list;
          end ;

          _T_h_e _f_i_l_e_s _a_r_e _c_o_m_p_i_l_e_d
          % cccc --cc cchh88aauuxxcc..cc
          1.0u 1.2s 0:15 14% 30+39k 33+20io 147pf+0w
          % ppcc --cc cchh88aauuxxpp..pp
          3.0u 1.7s 0:37 12% 27+32k 53+32io 143pf+0w

          % lliisspp
          Franz Lisp, Opus 38.60
          _F_i_r_s_t _t_h_e _f_i_l_e_s _a_r_e _l_o_a_d_e_d _a_n_d _w_e _s_e_t _u_p _o_n_e  _f_o_r_e_i_g_n  _f_u_n_c_-
          _t_i_o_n  _b_i_n_a_r_y_.  _W_e _h_a_v_e _t_w_o _f_u_n_c_t_i_o_n_s _i_n _e_a_c_h _f_i_l_e _s_o _w_e _m_u_s_t
          _c_h_o_o_s_e _o_n_e _t_o _t_e_l_l _c_f_a_s_l _a_b_o_u_t_.  _T_h_e _c_h_o_i_c_e _i_s _a_r_b_i_t_r_a_r_y_.
          -> ((ccffaassll ''cchh88aauuxxcc..oo ''__ccffoooo ''ccffoooo ""iinntteeggeerr--ffuunnccttiioonn""))
          /usr/lib/lisp/nld -N -A /usr/local/lisp -T 63000 ch8auxc.o -e _cfoo -o /tmp/Li7055.0  -lc
          #63000-"integer-function"
          -> ((ccffaassll ''cchh88aauuxxpp..oo ''__ppffoooo ''ppffoooo ""iinntteeggeerr--ffuunnccttiioonn"" ""--llppcc""))
          /usr/lib/lisp/nld -N -A /tmp/Li7055.0 -T 63200 ch8auxp.o -e _pfoo -o /tmp/Li7055.1 -lpc -lc
          #63200-"integer-function"
          _H_e_r_e _w_e _s_e_t _u_p _t_h_e _o_t_h_e_r _f_o_r_e_i_g_n _f_u_n_c_t_i_o_n _b_i_n_a_r_y _o_b_j_e_c_t_s
          -> ((ggeettaaddddrreessss ''__ccmmeemmqq ''ccmmeemmqq ""ffuunnccttiioonn"" ''__ppmmeemmqq ''ppmmeemmqq ""ffuunnccttiioonn""))
          #6306c-"function"
          _W_e _w_a_n_t _t_o _c_r_e_a_t_e _a_n_d _i_n_i_t_i_a_l_i_z_e _a_n _a_r_r_a_y  _t_o  _p_a_s_s  _t_o  _t_h_e
          _c_f_o_o  _f_u_n_c_t_i_o_n_.  _I_n _t_h_i_s _c_a_s_e _w_e _c_r_e_a_t_e _a_n _u_n_n_a_m_e_d _a_r_r_a_y _a_n_d
          _s_t_o_r_e _i_t _i_n _t_h_e _v_a_l_u_e _c_e_l_l _o_f _t_e_s_t_a_r_r_.  _W_h_e_n  _w_e  _c_r_e_a_t_e  _a_n
          _a_r_r_a_y  _t_o  _p_a_s_s  _t_o  _t_h_e  _P_a_s_c_a_l _p_r_o_g_r_a_m _w_e _w_i_l_l _u_s_e _a _n_a_m_e_d

                                             Printed: October 16, 1993

          FFuunnccttiioonnss,, FFcclloossuurreess,, aanndd MMaaccrrooss                        88--1166

          _a_r_r_a_y _j_u_s_t _t_o _d_e_m_o_n_s_t_r_a_t_e _t_h_e _d_i_f_f_e_r_e_n_t _w_a_y _t_h_a_t  _n_a_m_e_d  _a_n_d
          _u_n_n_a_m_e_d _a_r_r_a_y_s _a_r_e _c_r_e_a_t_e_d _a_n_d _a_c_c_e_s_s_e_d_.
          -> ((sseettqq tteessttaarrrr ((aarrrraayy nniill fflloonnuumm--bblloocckk 22))))
          array[2]
          -> ((ssttoorree ((ffuunnccaallll tteessttaarrrr 00)) 11..223344))
          1.234
          -> ((ssttoorree ((ffuunnccaallll tteessttaarrrr 11)) 55..667788))
          5.678
          -> ((ccffoooo 338855 tteessttaarrrr ((hhuunnkk 1100 1111 1133 1144)) ''((1155 1166 1177))))
          a: 385, b[0]: 1.234000, b[1]: 5.678000
           c (first): 10   c (second): 11
           ( 15 16 ... )
           3
          _N_o_t_e _t_h_a_t _c_f_o_o _h_a_s _r_e_t_u_r_n_e_d _3 _a_s _i_t _s_h_o_u_l_d_.  _I_t _a_l_s_o _h_a_d _t_h_e
          _s_i_d_e _e_f_f_e_c_t _o_f _c_h_a_n_g_i_n_g _t_h_e _s_e_c_o_n_d _v_a_l_u_e  _o_f  _t_h_e  _a_r_r_a_y  _t_o
          _3_._1_4_1_5_9_2_6  _w_h_i_c_h _c_h_e_c_k _n_e_x_t_.
          -> ((ffuunnccaallll tteessttaarrrr 11))
          3.1415926

          _I_n _p_r_e_p_a_r_a_t_i_o_n _f_o_r _c_a_l_l_i_n_g _p_f_o_o _w_e _c_r_e_a_t_e _a_n _a_r_r_a_y_.
          -> ((aarrrraayy tteesstt fflloonnuumm--bblloocckk 22))
          array[2]
          -> ((ssttoorree ((tteesstt 00)) 11..223344))
          1.234
          -> ((ssttoorree ((tteesstt 11)) 55..667788))
          5.678
          -> ((ppffoooo 338855 ((ggeettdd ''tteesstt)) ((hhuunnkk 1100 1111 1133 1144)) ''((1155 1166 1177))))
           a:       385 b[0]:  1.23400000000000E+00 b[1]:  5.67800000000000E+00
           c (first):        10 c (second):        11
           (         15        16 ...)
          3
          -> ((tteesstt 11))
          3.1415926

           _N_o_w _t_o _t_e_s_t _o_u_t _t_h_e _m_e_m_q_'_s
          _-_> ((ccmmeemmqq ''aa ''((bb cc aa dd ee ff))))
          _(_a _d _e _f_)
          _-_> ((ppmmeemmqq ''ee ''((aa dd ff gg aa xx))))
          _n_i_l
          ________________________________________________________________________________________________________________________

                     The Fortran example will be much shorter since in
                Fortran you can't follow pointers as you can in  other
                languages.   The  Fortran function ffoo is given three
                arguments:  a  fixnum,  a  fixnum-block  array  and  a
                flonum.   These  arguments  are  printed out to verify
                that they made it and then  the  first  value  of  the
                array  is  modified.   The  function  returns a double

                                             Printed: October 16, 1993

          FFuunnccttiioonnss,, FFcclloossuurreess,, aanndd MMaaccrrooss                        88--1177

                precision value which is converted to a flonum by lisp
                and  printed.  Note that the entry point corresponding
                to the Fortran function ffoo is _ffoo_ as  opposed  to
                the C and Pascal convention of preceding the name with
                an underscore.

          ____________________________________________________________

          % ccaatt cchh88aauuxxff..ff
                  double precision function ffoo(a,b,c)
                  integer a,b(10)
                  double precision c
                  print 2,a,b(1),b(2),c
          2       format(' a=',i4,', b(1)=',i5,', b(2)=',i5,' c=',f6.4)
                  b(1) = 22
                  ffoo = 1.23456
                  return
                  end
          % ff7777 --cc cchh88aauuxxff..ff
          ch8auxf.f:
             ffoo:
          0.9u 1.8s 0:12 22% 20+22k 54+48io 158pf+0w
          % lliisspp
          Franz Lisp, Opus 38.60
          -> ((ccffaassll ''cchh88aauuxxff..oo ''__ffffoooo__ ''ffffoooo ""rreeaall--ffuunnccttiioonn"" ""--llFF7777 --llII7777""))
          /usr/lib/lisp/nld -N -A /usr/local/lisp -T 63000 ch8auxf.o -e _ffoo_
          -o /tmp/Li11066.0 -lF77 -lI77 -lc
          #6307c-"real-function"

          -> ((aarrrraayy tteesstt ffiixxnnuumm--bblloocckk 22))
          array[2]
          -> ((ssttoorree ((tteesstt 00)) 1100))
          10
          -> ((ssttoorree ((tteesstt 11)) 1111))
          11
          -> ((ffffoooo 338855 ((ggeettdd ''tteesstt)) 55..667788))
           a= 385, b(1)=   10, b(2)=   11 c=5.6780
          1.234559893608093
          -> ((tteesstt 00))
          22

          ____________________________________________________________

                                             Printed: October 16, 1993


subroutine  succ(ksc,i,j,nadj,madj,ntot,nerror)

# Find the successor of j in the adjacency list of i.
# Called by addpt, initad, trifnd, swap, delout, dirseg, dirout.

implicit double precision(a-h,o-z)
dimension nadj(-3:ntot,0:madj)

nerror = -1

n = nadj(i,0)

# If the adjacency list of i is empty, then clearly j has no successor
# in this adjacency list.  Something's wrong; stop.
if(n==0) {
	nerror = 9
	return
}

# The adjacency list of i is non-empty; search through it until j is found;
# add 1 to the location of j, and find the contents of this new location.
do k = 1,n {
        if(j==nadj(i,k)) {
                kp = k+1
                if(kp>n) kp = 1         # Take kp modulo n. (The adjacency list
                ksc = nadj(i,kp)        # is circular.)
                return
        }
}

# The adjacency list doesn't contain j.  Something's wrong.
nerror = 10
return
end


#Copyright 2016 Lingjiao Chen, Arun Kumar, Jeffrey Naughton, and Jignesh M. Patel, Version 0.8.
#All rights reserved.
#
#Licensed under the Apache License, Version 2.0 (the "License");
#you may not use this file except in compliance with the License.
#You may obtain a copy of the License at
#
#    http://www.apache.org/licenses/LICENSE-2.0
#
#Unless required by applicable law or agreed to in writing, software
#distributed under the License is distributed on an "AS IS" BASIS,
#WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
#See the License for the specific language governing permissions and
#limitations under the License.

library(Matrix);
NormalMatrix <- setClass (
	"NormalMatrix",
	slots = c (
		EntTable = "list",
		AttTables = "list",
		KFKDs = "list",
		Trans = "logical",
		Sparse = "logical"
		),
	prototype=prototype(Trans=FALSE,Sparse=FALSE)
	)

#############################################
# Transpose Rule
't.NormalMatrix' <- function( NM1)
{
	NM1@Trans=!NM1@Trans;
	return(NM1);
}
#############################################

#############################################
# Element-wise Scalar Operators
setMethod("+", c("numeric","NormalMatrix"), function(e1,e2) {
	Rnum = length(e2@AttTables);
	Sempty = nrow(e2@EntTable[[1]])*ncol(e2@EntTable[[1]]);
	if(Sempty!=0)
	{
		e2@EntTable[[1]]=e2@EntTable[[1]]+e1;
	}
	for(i in 1:Rnum)
	{
		e2@AttTables[[i]] = e2@AttTables[[i]]+e1;
	}
	return(e2);
})

setMethod("+", c("NormalMatrix","numeric"), function(e1,e2) {
	Rnum = length(e1@AttTables);
	Sempty = nrow(e1@EntTable[[1]])*ncol(e1@EntTable[[1]]);
	if(Sempty!=0)
	{
		e1@EntTable[[1]]=e1@EntTable[[1]]+e2;
	}
	for(i in 1:Rnum)
	{
		e1@AttTables[[i]] = e1@AttTables[[i]]+e2;
	}
	return(e1);
})

setMethod("-", c("numeric","NormalMatrix"), function(e1,e2) {
	Rnum = length(e2@AttTables);
	Sempty = nrow(e2@EntTable[[1]])*ncol(e2@EntTable[[1]]);
	if(Sempty!=0)
	{
		e2@EntTable[[1]]=e2@EntTable[[1]]-e1;
	}
	for(i in 1:Rnum)
	{
		e2@AttTables[[i]] = e2@AttTables[[i]]-e1;
	}
	return(e2);
})

setMethod("-", c("NormalMatrix","numeric"), function(e1,e2) {
	Rnum = length(e1@AttTables);
	Sempty = nrow(e1@EntTable[[1]])*ncol(e1@EntTable[[1]]);
	if(Sempty!=0)
	{
		e1@EntTable[[1]]=e1@EntTable[[1]]-e2;
	}
	for(i in 1:Rnum)
	{
		e1@AttTables[[i]] = e1@AttTables[[i]]-e2;
	}
	return(e1);
})

setMethod("*", c("numeric","NormalMatrix"), function(e1,e2) {
	Rnum = length(e2@AttTables);
	Sempty = nrow(e2@EntTable[[1]])*ncol(e2@EntTable[[1]]);
	if(Sempty!=0)
	{
		e2@EntTable[[1]]=e2@EntTable[[1]]*e1;
	}
	for(i in 1:Rnum)
	{
		e2@AttTables[[i]] = e2@AttTables[[i]]*e1;
	}
	return(e2);
})

setMethod("*", c("NormalMatrix","numeric"), function(e1,e2) {
	Rnum = length(e1@AttTables);
	Sempty = nrow(e1@EntTable[[1]])*ncol(e1@EntTable[[1]]);
	if(Sempty!=0)
	{
		e1@EntTable[[1]]=e1@EntTable[[1]]*e2;
	}
	for(i in 1:Rnum)
	{
		e1@AttTables[[i]] = e1@AttTables[[i]]*e2;
	}
	return(e1);
})

setMethod("/", c("numeric","NormalMatrix"), function(e1,e2) {
	Rnum = length(e2@AttTables);
	Sempty = nrow(e2@EntTable[[1]])*ncol(e2@EntTable[[1]]);
	if(Sempty!=0)
	{
		e2@EntTable[[1]]=e2@EntTable[[1]]/e1;
	}
	for(i in 1:Rnum)
	{
		e2@AttTables[[i]] = e2@AttTables[[i]]/e1;
	}
	return(e2);
})

setMethod("/", c("NormalMatrix","numeric"), function(e1,e2) {
	Rnum = length(e1@AttTables);
	Sempty = nrow(e1@EntTable[[1]])*ncol(e1@EntTable[[1]]);
	if(Sempty!=0)
	{
		e1@EntTable[[1]]=e1@EntTable[[1]]/e2;
	}
	for(i in 1:Rnum)
	{
		e1@AttTables[[i]] = e1@AttTables[[i]]/e2;
	}
	return(e1);
})

setMethod("^", c("numeric","NormalMatrix"), function(e1,e2) {
	Rnum = length(e2@AttTables);
	Sempty = nrow(e2@EntTable[[1]])*ncol(e2@EntTable[[1]]);
	if(Sempty!=0)
	{
		e2@EntTable[[1]]=e2@EntTable[[1]]^e1;
	}
	for(i in 1:Rnum)
	{
		e2@AttTables[[i]] = e2@AttTables[[i]]^e1;
	}
	return(e2);
})

setMethod("^", c("NormalMatrix","numeric"), function(e1,e2) {
	Rnum = length(e1@AttTables);
	Sempty = nrow(e1@EntTable[[1]])*ncol(e1@EntTable[[1]]);
	if(Sempty!=0)
	{
		e1@EntTable[[1]]=e1@EntTable[[1]]^e2;
	}
	for(i in 1:Rnum)
	{
		e1@AttTables[[i]] = e1@AttTables[[i]]^e2;
	}
	return(e1);
})

#############################################

#############################################
#Aggregation
setMethod("sum", c("NormalMatrix"), function(x) {
	Sempty = nrow(x@EntTable[[1]])*ncol(x@EntTable[[1]]);
	y = ifelse(Sempty!=0,sum(x@EntTable[[1]]),0 );
	Rnum = length(x@AttTables);
	for(i in 1:Rnum)
	{
		y = y + colSums(x@KFKDs[[i]])%*%rowSums(x@AttTables[[i]]);
	}
	return(y);
})

setMethod("rowSums", c("NormalMatrix"), function(x) {
	if(x@Trans==TRUE)
	{
		return(t(NormalMatrixcolSums(x)));
	}
	else
	{
		return(NormalMatrixrowSums(x));
	}
})

setMethod("colSums", c("NormalMatrix"), function(x) {
	if(x@Trans==TRUE)
	{
		return(t(NormalMatrixrowSums(x)));
	}
	else
	{
		return(NormalMatrixcolSums(x));
	}
})

NormalMatrixrowSums <- function(x){
	Sempty = nrow(x@EntTable[[1]])*ncol(x@EntTable[[1]]);
	i = 1;
	if(Sempty!=0)
	{
		y = rowSums(x@EntTable[[1]])+as.numeric(x@KFKDs[[i]]%*%rowSums(x@AttTables[[i]]));;
	}
	else
	{
		y = as.numeric(x@KFKDs[[i]]%*%rowSums(x@AttTables[[i]]));
	}
	Rnum = length(x@AttTables);
	i = 2;
	while(i <= Rnum)
	{
		y = y + as.numeric(x@KFKDs[[i]]%*%rowSums(x@AttTables[[i]]));
		i = i + 1;
	}
	return(y);
}

NormalMatrixcolSums <- function(x){
	Sempty = nrow(x@EntTable[[1]])*ncol(x@EntTable[[1]]);
	Rnum = length(x@AttTables);
	if(Sempty!=0)
	{
		y = c(colSums(x@EntTable[[1]]), colSums(x@KFKDs[[1]])%*%x@AttTables[[1]]);
	}
	else
	{
		y = colSums(x@KFKDs[[1]])%*%x@AttTables[[1]];
	}
	i = 2;
	while(i <= Rnum)
	{
		y = c(y, colSums(x@KFKDs[[i]])%*%x@AttTables[[i]] );
		i = i + 1;
	}
	return(y);
}

#############################################

#############################################
# Multiplication

# Left Matrix Multiplication
NormalMatrixLMM <- function(x,y)
{
	Sempty = nrow(x@EntTable[[1]])*ncol(x@EntTable[[1]]);
	Rnum = length(x@AttTables);
	if(x@Sparse==TRUE) # EntTable is empty
	{
		if(Sempty==0) # EntTable is empty
		{
			Out1 = x@KFKDs[[1]] %*% (x@AttTables[[1]] %*% y[1:(ncol(x@AttTables[[1]]) ),] );
		}
		else
		{
			Out1 = x@EntTable[[1]]%*% y[1:(ncol(x@EntTable[[1]]) ),] + x@KFKDs[[1]] %*% (x@AttTables[[1]] %*% y[(1+ncol(x@EntTable[[1]])):(ncol(x@AttTables[[1]])+ncol(x@EntTable[[1]]) ),] );
		}
		StartCol = ncol(x@EntTable[[1]])+ncol(x@AttTables[[1]]);
		i = 2;
		while(i <= Rnum) # multi-table joins
		{
			Out1 = Out1 + (x@KFKDs[[i]]) %*% (x@AttTables[[i]] %*% y[(1+StartCol):(StartCol+ncol(x@AttTables[[i]]) ),] );
			StartCol=StartCol+(ncol(x@AttTables[[i]]) );
			i = i + 1;
		}
		return (Out1);
	}
	else
	{
		if(Sempty==0) # EntTable is empty
		{
			Out1 = as.matrix(x@KFKDs[[1]] %*% (x@AttTables[[1]] %*% y[1:(ncol(x@AttTables[[1]]) ),] ));
		}
		else
		{
			Out1 = x@EntTable[[1]]%*% y[1:(ncol(x@EntTable[[1]]) ),] + as.matrix(x@KFKDs[[1]] %*% (x@AttTables[[1]] %*% y[(1+ncol(x@EntTable[[1]])):(ncol(x@AttTables[[1]])+ncol(x@EntTable[[1]]) ),] ));
		}
		StartCol = ncol(x@EntTable[[1]])+ncol(x@AttTables[[1]]);
		i = 2;
		while(i <= Rnum) # multi-table joins
		{
			Out1 = Out1 + as.matrix((x@KFKDs[[i]]) %*% (x@AttTables[[i]] %*% y[(1+StartCol):(StartCol+ncol(x@AttTables[[i]]) ),] ));
			StartCol=StartCol+(ncol(x@AttTables[[i]]) );
			i = i + 1;
		}
		return (Out1);

	}
}

# Right Matrix Multiplication
NormalMatrixRMM <- function(x,y)
{
	Sempty = nrow(y@EntTable[[1]])*ncol(y@EntTable[[1]]);
	Rnum = length(y@AttTables);
	if(y@Sparse==TRUE)# Sparse
	{
		if(Sempty==0) # EntTable is empty
		{
			Out1 = (x %*% y@KFKDs[[1]])%*%y@AttTables[[1]];
		}
		else
		{
			Out1 = cbind(x%*% y@EntTable[[1]],(x %*% y@KFKDs[[1]])%*%y@AttTables[[1]]);
		}
		i = 2;
		while( i <= Rnum) # multi-table joins
		{
			Out1 = cbind(Out1,(x %*% y@KFKDs[[i]])%*%y@AttTables[[i]]);
			i = i + 1;
		}
		return (Out1);
	}
	else
	{
		if(Sempty==0) # EntTable is empty
		{
			Out1 = as.matrix(x %*% y@KFKDs[[1]])%*%y@AttTables[[1]];
		}
		else
		{
			Out1 = cbind(x%*% y@EntTable[[1]],as.matrix(x %*% y@KFKDs[[1]])%*%y@AttTables[[1]]);
		}
		i = 2;
		while( i <= Rnum) # multi-table joins
		{
			Out1 = cbind(Out1,as.matrix(x %*% y@KFKDs[[i]])%*%y@AttTables[[i]]);
			i = i + 1;
		}
		return (Out1);
	}
}

# API for LMM and RMM with different matrix types.

#LMM API.
setMethod("%*%", c("NormalMatrix","dgCMatrix"), function(x,y)
{
	if(x@Trans==FALSE)
	{
		return( NormalMatrixLMM(x,y) );
	}
	else
	{
		return( t(NormalMatrixRMM(t(y),x)) );
	}
})

setMethod("%*%", c("NormalMatrix","matrix"), function(x,y)
{
	if(x@Trans==FALSE)
	{
		return( NormalMatrixLMM(x,y) );
	}
	else
	{
		return( t(NormalMatrixRMM(t(y),x)) );
	}
})

setMethod("%*%", c("NormalMatrix","dgeMatrix"), function(x,y)
{
	if(x@Trans==FALSE)
	{
		return( NormalMatrixLMM(x,y) );
	}
	else
	{
		return( t(NormalMatrixRMM(t(y),x)) );
	}
})

setMethod("%*%", c("NormalMatrix","lgCMatrix"), function(x,y)
{
	if(x@Trans==FALSE)
	{
		return( NormalMatrixLMM(x,y) );
	}
	else
	{
		return( t(NormalMatrixRMM(t(y),x)) );
	}
})

#RMM API.
setMethod("%*%", c("dgCMatrix","NormalMatrix"), function(x,y) {
	if(y@Trans==FALSE)
	{
		return( NormalMatrixRMM(x,y) );
	}
	else
	{
		return( t(NormalMatrixLMM(y,t(x))) );
	}
})

setMethod("%*%", c("dgeMatrix","NormalMatrix"), function(x,y) {
	if(y@Trans==FALSE)
	{
		return( NormalMatrixRMM(x,y) );
	}
	else
	{
		return( t(NormalMatrixLMM(y,t(x))) );
	}
})

setMethod("%*%", c("lgCMatrix","NormalMatrix"), function(x,y) {
	if(y@Trans==FALSE)
	{
		return( NormalMatrixRMM(x,y) );
	}
	else
	{
		return( t(NormalMatrixLMM(y,t(x))) );
	}
})

setMethod("%*%", c("matrix","NormalMatrix"), function(x,y) {
	if(y@Trans==FALSE)
	{
		return( NormalMatrixRMM(x,y) );
	}
	else
	{
		return( t(NormalMatrixLMM(y,t(x))) );
	}
})

#############################################

#############################################
#Derived Multiplication Operators.
#Include Crossprod and double multiplication.
#############################################

#############################################
# Cross Product
NormalMatrixCrossprod <- function(x)
{
	Sempty = nrow(x@EntTable[[1]])*ncol(x@EntTable[[1]]);
	Rnum = length(x@AttTables);
	if(x@Sparse==TRUE)# Sparse
	{
		if(Sempty==0) # EntTable is empty
		{
			Out1 = ( crossprod( Diagonal( x=colSums(x@KFKDs[[1]])^{1/2} ) %*% x@AttTables[[1]]) ) ;
			i = 2;
			while( i <= Rnum) # multi-table joins
			{
				# Construct Y_21
				j = 1;
				Y21 = crossprod( x@AttTables[[i]], crossprod(crossprod(x@KFKDs[[j]], x@KFKDs[[i]] ), x@AttTables[[j]]) ) ;
				j = 2;
				while( j <=(i-1))
				{
					j = j + 1;
					Y21 = cbind(Y21, crossprod( x@AttTables[[i]], crossprod(crossprod(x@KFKDs[[j]], x@KFKDs[[i]] ), x@AttTables[[j]]) )) ;
				}
				Out1 = (rbind( cbind(Out1,t(Y21) ) , cbind( Y21, (crossprod( Diagonal( x=colSums(x@KFKDs[[i]])^{1/2} ) %*% x@AttTables[[i]]) ) )) );
				i = i + 1;
			}
			return( Out1 );
		}
		else
		{
			Y21 = crossprod(x@AttTables[[1]], ( crossprod(x@KFKDs[[1]], x@EntTable[[1]])  ) );
			Out1 = (rbind( cbind(crossprod(x@EntTable[[1]]),t(Y21) ) , cbind( Y21, (crossprod( Diagonal( x=colSums(x@KFKDs[[1]])^{1/2} ) %*% x@AttTables[[1]]) ) )) );
			i = 2;
			while( i <= Rnum) # multi-table joins
			{
				# Construct Y_21
				Y21 = crossprod(x@AttTables[[i]], ( crossprod(x@KFKDs[[i]], x@EntTable[[1]])  ) );
				for( j in 1:(i-1))
				{
					Y21 = cbind(Y21, crossprod( x@AttTables[[i]], crossprod(crossprod(x@KFKDs[[j]], x@KFKDs[[i]] ), x@AttTables[[j]]) )) ;
				}
				Out1 = (rbind( cbind(Out1,t(Y21) ) , cbind( Y21, (crossprod( Diagonal( x=colSums(x@KFKDs[[i]])^{1/2} ) %*% x@AttTables[[i]]) ) )) );
				i = i + 1;
			}
			return( Out1 );
		}
	}
	else
	{
		if(Sempty==0) # EntTable is empty
		{
			Out1 = as.matrix( crossprod( Diagonal( x=colSums(x@KFKDs[[1]])^{1/2} ) %*% x@AttTables[[1]]) ) ;
			i = 2;
			while( i <= Rnum) # multi-table joins
			{
				# Construct Y_21
				j = 1;
				Y21 = crossprod( x@AttTables[[i]], as.matrix(crossprod(crossprod(x@KFKDs[[j]], x@KFKDs[[i]] ), x@AttTables[[j]]) )) ;
				j = 2;
				while( j <=(i-1))
				{
					j = j + 1;
					Y21 = cbind(Y21, crossprod( x@AttTables[[i]], as.matrix(crossprod(crossprod(x@KFKDs[[j]], x@KFKDs[[i]] ), x@AttTables[[j]]) )) ) ;
				}
				Out1 = (rbind( cbind(Out1,t(Y21) ) , cbind( Y21, as.matrix(crossprod( Diagonal( x=colSums(x@KFKDs[[i]])^{1/2} ) %*% x@AttTables[[i]]) ) )) );
				i = i + 1;
			}
			return( Out1 );
		}
		else
		{
			Y21 = crossprod(x@AttTables[[1]], as.matrix( crossprod(x@KFKDs[[1]], x@EntTable[[1]])  ) );
			Out1 = (rbind( cbind(crossprod(x@EntTable[[1]]),t(Y21) ) , cbind( Y21, as.matrix(crossprod( Diagonal( x=colSums(x@KFKDs[[1]])^{1/2} ) %*% x@AttTables[[1]]) ) )) );
			i = 2;
			while( i <= Rnum) # multi-table joins
			{
				# Construct Y_21
				Y21 = crossprod(x@AttTables[[i]], ( crossprod(x@KFKDs[[i]], x@EntTable[[1]])  ) );
				for( j in 1:(i-1))
				{
					Y21 = cbind(Y21, crossprod( x@AttTables[[i]], as.matrix(crossprod(crossprod(x@KFKDs[[j]], x@KFKDs[[i]] ), x@AttTables[[j]]) ))) ;
				}
				Out1 = (rbind( cbind(Out1,t(Y21) ) , cbind( Y21, as.matrix(crossprod( Diagonal( x=colSums(x@KFKDs[[i]])^{1/2} ) %*% x@AttTables[[i]]) ) )) );
				i = i + 1;
			}
			return( Out1 );
		}
	}
}

# Transpose Cross Product
NormalMatrixCrossprodTrans <- function(x)
{
	Sempty = nrow(x@EntTable[[1]])*ncol(x@EntTable[[1]]);
	Rnum = length(x@AttTables);
	if(x@Sparse==TRUE)# Sparse
	{
		if(Sempty==0) # EntTable is empty
		{
			Out1 = tcrossprod(x@KFKDs[[1]] %*% tcrossprod(x@AttTables[[1]]), x@KFKDs[[1]]);
		}
		else
		{
			Out1 = tcrossprod(x@EntTable[[1]]) + tcrossprod(x@KFKDs[[1]] %*% tcrossprod(x@AttTables[[1]]), x@KFKDs[[1]]);
		}
		i = 2;
		while( i <= Rnum) # multi-table joins
		{
			Out1 = Out1 + tcrossprod(x@KFKDs[[i]] %*% tcrossprod(x@AttTables[[i]]), x@KFKDs[[i]]);
			i = i + 1;
		}
		return( Out1 );
	}
	else
	{
		if(Sempty==0) # EntTable is empty
		{
			Out1 = as.matrix(tcrossprod(x@KFKDs[[1]] %*% tcrossprod(x@AttTables[[1]]), x@KFKDs[[1]]));
		}
		else
		{
			Out1 = tcrossprod(x@EntTable[[1]]) + as.matrix(tcrossprod(x@KFKDs[[1]] %*% tcrossprod(x@AttTables[[1]]), x@KFKDs[[1]]));
		}
		i = 2;
		while( i <= Rnum) # multi-table joins
		{
			Out1 = Out1 + as.matrix(tcrossprod(x@KFKDs[[i]] %*% tcrossprod(x@AttTables[[i]]), x@KFKDs[[i]]));
			i = i + 1;
		}
		return( Out1 );
	}
}

# Crossprod API
setMethod("crossprod", c("NormalMatrix"), function(x) {
	if(x@Trans==FALSE)
	{
		return( NormalMatrixCrossprod(x) );
	}
	else
	{
		return( (NormalMatrixCrossprodTrans(x)) );
	}
})

setMethod("tcrossprod", c("NormalMatrix"), function(x) {
	if(x@Trans==FALSE)
	{
		return( NormalMatrixCrossprodTrans(x) );
	}
	else
	{
		return( (NormalMatrixCrossprod(x)) );
	}
})
#############################################

#############################################
#Double Multiplication

#############################################
# Cross Product Alike, i.e., t(A)%*% B
# Warning: Only test the case when A = B.
NormalMatrixCrossprod2M <- function(x,y)
{
	Sempty1 = nrow(x@EntTable[[1]])*ncol(x@EntTable[[1]]);
	Rnum1 = length(x@AttTables);
	Sempty2 = nrow(y@EntTable[[1]])*ncol(y@EntTable[[1]]);
	Rnum2 = length(y@AttTables);
	if(x@Sparse==TRUE)# Sparse
	{
		# First compute attribute tables
		i = 1;
		j = 1;
		Out1 = t(x@AttTables[[i]]) %*%( t(x@KFKDs[[i]]) %*% y@KFKDs[[j]] ) %*% (y@AttTables[[j]]);
		j = j+1;
		while( 2<=j && j<= Rnum2)# Enter this loop only if B is multi-table.
		{
			Out1 = cbind(Out1,t(x@AttTables[[i]]) %*%( t(x@KFKDs[[i]]) %*% y@KFKDs[[j]] ) %*% (y@AttTables[[j]]));
			j = j+1;
		}
		i = i+1;
		while( 2<=i && i<=Rnum1 ) # Enter this loop only if A is multi-table.
		{
			j = 1;
			Temp = t(x@AttTables[[i]]) %*%( t(x@KFKDs[[i]]) %*% y@KFKDs[[j]] ) %*% (y@AttTables[[j]]);
			j = j+1;
			while( 2<=j && j<= Rnum2)# Enter this loop only if B is multi-table.
			{
				Temp = cbind(Temp,t(x@AttTables[[i]]) %*%( t(x@KFKDs[[i]]) %*% y@KFKDs[[j]] ) %*% (y@AttTables[[j]]));
				j = j+1;
			}
			Out1 = rbind(Out1,Temp);
			i=i+1;
		}
		# Finish attribute tables.

		# Consider Entity table.
		if(Sempty1 == 0 && Sempty2 != 0 ) # No Entity table in A.
		{
			j = 1;
			Temp = t(x@AttTables[[j]]) %*%( t(x@KFKDs[[j]]) %*% y@EntTable[[1]] ) ;
			j = j+1;
			while( 2<=j && j<= Rnum1)# Enter this loop only if A is multi-table.
			{
				Temp = rbind(Temp,t(x@AttTables[[j]]) %*%( t(x@KFKDs[[j]]) %*% y@EntTable[[1]] ));
				j = j+1;
			}
			Out1 = cbind(Temp,Out1);
		}
		if(Sempty1 != 0 && Sempty2 == 0 ) # No Entity table in B.
		{
			j = 1;
			Temp = (t(x@EntTable[[1]]) %*% y@KFKDs[[j]]) %*% y@AttTables[[j]]  ;
			j = j+1;
			while( 2<=j && j<= Rnum2)# Enter this loop only if B is multi-table.
			{
				Temp = cbind(Temp,(t(x@EntTable[[1]]) %*% y@KFKDs[[j]]) %*% y@AttTables[[j]] );
				j = j+1;
			}
			Out1 = rbind(Temp,Out1);
		}
		if(Sempty1 != 0 && Sempty2 != 0 ) # Both with Entity table.
		{
			# EntTable in A.
			j = 1;
			Temp = t(x@AttTables[[j]]) %*%( t(x@KFKDs[[j]]) %*% y@EntTable[[1]] ) ;
			j = j+1;
			while( 2<=j && j<= Rnum1)# Enter this loop only if A is multi-table.
			{
				Temp = rbind(Temp,t(x@AttTables[[j]]) %*%( t(x@KFKDs[[j]]) %*% y@EntTable[[1]] ) );
				j = j+1;
			}
			Out1 = cbind(Temp,Out1);
			# EntTable in B.
			j = 1;
			Temp = cbind( (t(x@EntTable[[1]]) %*% y@EntTable[[1]]) , (t(x@EntTable[[1]]) %*% y@KFKDs[[j]]) %*% y@AttTables[[j]] ) ;
			j = j+1;
			while( 2<=j && j<= Rnum2)# Enter this loop only if B is multi-table.
			{
				Temp = cbind(Temp,(t(x@EntTable[[1]]) %*% y@KFKDs[[j]]) %*% y@AttTables[[j]] );
				j = j+1;
			}
			Out1 = rbind(Temp,Out1);
		}

			return(Out1);
	}
	else
	{
		# First compute attribute tables
		i = 1;
		j = 1;
		Out1 = t(x@AttTables[[i]]) %*%as.matrix(( t(x@KFKDs[[i]]) %*% y@KFKDs[[j]] ) %*% (y@AttTables[[j]]));
		j = j+1;
		while( 2<=j && j<= Rnum2)# Enter this loop only if B is multi-table.
		{
			Out1 = cbind(Out1,t(x@AttTables[[i]]) %*%as.matrix(( t(x@KFKDs[[i]]) %*% y@KFKDs[[j]] ) %*% (y@AttTables[[j]])));
			j = j+1;
		}
		i = i+1;
		while( 2<=i && i<=Rnum1 ) # Enter this loop only if A is multi-table.
		{
			j = 1;
			Temp = t(x@AttTables[[i]]) %*%as.matrix(( t(x@KFKDs[[i]]) %*% y@KFKDs[[j]] ) %*% (y@AttTables[[j]]));
			j = j+1;
			while( 2<=j && j<= Rnum2)# Enter this loop only if B is multi-table.
			{
				Temp = cbind(Temp,t(x@AttTables[[i]]) %*%as.matrix(( t(x@KFKDs[[i]]) %*% y@KFKDs[[j]] ) %*% (y@AttTables[[j]])));
				j = j+1;
			}
			Out1 = rbind(Out1,Temp);
			i=i+1;
		}
		# Finish attribute tables.

		# Consider Entity table.
		if(Sempty1 == 0 && Sempty2 != 0 ) # No Entity table in A.
		{
			j = 1;
			Temp = t(x@AttTables[[j]]) %*%as.matrix( t(x@KFKDs[[j]]) %*% y@EntTable[[1]] ) ;
			j = j+1;
			while( 2<=j && j<= Rnum1)# Enter this loop only if A is multi-table.
			{
				Temp = rbind(Temp,t(x@AttTables[[j]]) %*%as.matrix( t(x@KFKDs[[j]]) %*% y@EntTable[[1]] ) );
				j = j+1;
			}
			Out1 = cbind(Temp,Out1);
		}
		if(Sempty1 != 0 && Sempty2 == 0 ) # No Entity table in B.
		{
			j = 1;
			Temp = as.matrix(t(x@EntTable[[1]]) %*% y@KFKDs[[j]]) %*% y@AttTables[[j]]  ;
			j = j+1;
			while( 2<=j && j<= Rnum2)# Enter this loop only if B is multi-table.
			{
				Temp = cbind(Temp,as.matrix(t(x@EntTable[[1]]) %*% y@KFKDs[[j]]) %*% y@AttTables[[j]] );
				j = j+1;
			}
			Out1 = rbind(Temp,Out1);
		}
		if(Sempty1 != 0 && Sempty2 != 0 ) # Both with Entity table.
		{
			# EntTable in A.
			j = 1;
			Temp = t(x@AttTables[[j]]) %*%as.matrix( t(x@KFKDs[[j]]) %*% y@EntTable[[1]] ) ;
			j = j+1;
			while( 2<=j && j<= Rnum1)# Enter this loop only if A is multi-table.
			{
				Temp = rbind(Temp,t(x@AttTables[[j]]) %*%as.matrix( t(x@KFKDs[[j]]) %*% y@EntTable[[1]] ) );
				j = j+1;
			}
			Out1 = cbind(Temp,Out1);
			# EntTable in B.
			j = 1;
			Temp = cbind( (t(x@EntTable[[1]]) %*% y@EntTable[[1]]) , as.matrix(t(x@EntTable[[1]]) %*% y@KFKDs[[j]]) %*% y@AttTables[[j]] ) ;
			j = j+1;
			while( 2<=j && j<= Rnum2)# Enter this loop only if B is multi-table.
			{
				Temp = cbind(Temp,as.matrix(t(x@EntTable[[1]]) %*% y@KFKDs[[j]]) %*% y@AttTables[[j]] );
				j = j+1;
			}
			Out1 = rbind(Temp,Out1);
		}
		return( Out1 );
	}
}

#Note: Double Multiplication is not fully optimized.
#############################################

#############################################
# M:N joins
NormalMatrixJoin <- function(S,R,SJA,RJA,IsSparse=FALSE){
	# Input : S, R, SJA, RJA
	nS = nrow(S);
	dS = ncol(S);
	nR = nrow(R);
	dR = ncol(R);

	SJAS = sparseMatrix(c(1:nS),SJA );
	RJAS = sparseMatrix(c(1:nR),RJA );
	if( ncol(SJAS) > ncol(RJAS) )
	{
		SJAS = SJAS[,1:ncol(RJAS)];
	}
	if( ncol(SJAS) < ncol(RJAS) )
	{
		RJAS = RJAS[,1:ncol(SJAS)];
	}
	JM = SJAS %*%t(RJAS);
	nT = sum(colSums((JM)));
	if(nT!=0)
	{
		JMS = summary(JM);
		SJM = sparseMatrix(c(1:nT),JMS[,1],dims=c(nT,nS),x=1);
		RJM = sparseMatrix(c(1:nT),JMS[,2],dims=c(nT,nR),x=1);
	}
	if(nT==0)
	{
		SJM = Matrix(0,nT,nS);
		RJM = Matrix(0,nT,nR);
	}
	S0 = matrix(0,0,0);
	TNM = NormalMatrix(EntTable=list(S0),AttTables=list(S,R),KFKDs=list(SJM,RJM),Sparse=IsSparse);
	return (TNM);
}
#############################################
#Handle conflicts with regular matrix package
setMethod(Ops, c("NormalMatrix","NormalMatrix"), function(e1,e2) {
	return ();
})


individuals <- c("C010_pennunk", "C016_pennunk", "C018_pennunk", "C036_modoc", "C002_modoc", "C019_modoc", "C046_laevigatus", "C003_laevigatus", "C049_herculeanus","C050_herculeanus", "C056_herculeanus", "C039_vicinus",  "C005_vicinus", "C028_vicinus", "C024_vicinusunk", "C029_vicinusunk", "C006_ocreatus")
# species
species <- unique(sapply(strsplit(individuals, "_"), "[[", 2))
species
# "pennunk"     "modoc"       "laevigatus"  "herculeanus" "vicinus"     "vicinusunk"  "ocreatus"

# define parameters
# gen time = 2 * age of sexual maturity in closely-related species from ant literature (3-4 years depending on estimate)
# age of sex. maturity = ~3 years
# method citation = doi: 10.1016/j.cub.2015.03.047
gen <- 6
mu <- 1.983877e-09 #* gen # needs to be per generation
# plotting numbers
min_age <- 000
max_age <- 1000000
plotting_age_range <- 1000 # years for x axis

# loop through each output directory
output <- list()
output_bootstraps <- list()
for(a in 1:length(individuals)) {
	# identify bootstraps
	a_bootstraps <- paste("output/", individuals[a], "_b", seq(from=1, to=10, by=1), ".final.txt", sep="")
	# identify main output file
	a_main <- paste("output/", individuals[a], ".final.txt", sep="")

	# read in main file
	a_rep <- read.table(a_main, sep="\t", header=T)
	# rearrange main file for plotting lines
	for(d in 1:nrow(a_rep)) {
		if(d == 1) {
			a_rep2 <- rbind(c(a_rep[d,2], a_rep[d,4]), c(a_rep[d,3], a_rep[d,4]))
		} else {
			a_rep2 <- rbind(a_rep2, c(a_rep[d,2], a_rep[d,4]), c(a_rep[d,3], a_rep[d,4]))
		}
	}
	a_rep <- a_rep2
	# scale by mutation rate
	a_rep[,1] <- a_rep[,1] / mu * gen
	a_rep[,2] <- (1 / a_rep[,2]) / (2 * mu)
	# remove very young and old time frames prone to error
	a_rep <- a_rep[a_rep[,1] >= min_age & a_rep[,1] <= max_age,]
	# scale by plotting age range and pop size range
	a_rep <- a_rep / plotting_age_range
	# add to output list
	output[[a]] <- a_rep

	# output for each bootstrap
	output_bootstraps[[a]] <- list()
	for(b in 1:length(a_bootstraps)) {
		b_rep <- read.table(a_bootstraps[b], sep="\t", header=T)
		# rearrange main file for plotting lines
		for(d in 1:nrow(b_rep)) {
			if(d == 1) {
				b_rep2 <- rbind(c(b_rep[d,2], b_rep[d,4]), c(b_rep[d,3], b_rep[d,4]))
			} else {
				b_rep2 <- rbind(b_rep2, c(b_rep[d,2], b_rep[d,4]), c(b_rep[d,3], b_rep[d,4]))
			}
		}
		b_rep <- b_rep2
		# scale by mutation rate
		b_rep[,1] <- b_rep[,1] / mu * gen
		b_rep[,2] <- (1 / b_rep[,2]) / (2 * mu)
		# remove very young and old time frames prone to error
		b_rep <- b_rep[b_rep[,1] >= min_age & b_rep[,1] <= max_age,]
		# scale by plotting age range and pop size range
		b_rep <- b_rep / plotting_age_range
		# add to output list
		output_bootstraps[[a]][[b]] <- b_rep
	}
}

# plot all separate
a_col <- "darkgreen"
par(mfrow=c(4,5))
par(mar=c(4.5,4.5,2,0.2))
for(a in 1:length(output)) {
	plot_name1 <- individuals[a]
	plot(c(-1,1), xlim=c(50, 900), ylim=c(0,500), pch=19, cex=0.01, log="x", xlab="kya", ylab="Pop. Size (1000s)", main="", xaxt="n", yaxt="n")
	title(main=bquote(italic(.(plot_name1))), adj=0,line=0.5, cex.main=1.5)
	axis(side=2, at=c(0, 150, 300, 450), labels=T)
	axis(side=1, at=c(20, 50, 100, 200, 500, 900), labels=T)

	# plot bootstraps
	for(b in 1:length(output_bootstraps[[1]])) {
		lines(output_bootstraps[[a]][[b]][,1], output_bootstraps[[a]][[b]][,2], col=a_col, lwd=0.3)
	}
	lines(output[[a]][,1], output[[a]][,2], col=a_col, lwd=3)
}

# define current pop sizes
current_pop <- c()
for(a in 1:length(output)) {
	current_pop <- c(current_pop, output[[a]][1,2])
}

# harmonic mean of pop sizes from most recent to 500k years ago
harmonic_pop <- c()
for(a in 1:length(output)) {
	out_rep <- output[[a]]

	# define time series
	time_series <- seq(from=as.integer(out_rep[2,1])+1, to=500, by=1)
	# time series pops
	time_pops <- c()
	for(b in 1:length(time_series)) {
		time_pops <- c(time_pops, out_rep[time_series[b] < out_rep[,1],][1,2])
	}
	# harmonic mean of this individual
	harm_rep <- length(time_pops) / sum((1 / time_pops))

	# add to output element
	harmonic_pop <- c(harmonic_pop, harm_rep)
}

# read in diversity table
div <- read.table("01_heterozygosity_per_individual.txt", header=T, stringsAsFactors=F)
# remove outgroups
div <- div[div$number <= 17, ]

# define output to match with diversity table
output <- data.frame(individual=as.character(gsub("C", "C-", sapply(strsplit(individuals, "_"), "[[", 1))), current_pop=as.numeric(current_pop), harmonic_pop=as.numeric(harmonic_pop))
# rearrange
output <- output[match(div$individual, output$individual),]
# combine outputs
div <- cbind(div, output)
# remove duplicate individuals column after checking
div <- div[,-6]

#write output
write.table(div, file="01_heterozygosity_and_pop_sizes.txt", sep="\t", row.names=F, quote=F)