REBOL [
  Title: "Relations Engine"
  File: %relations.r
  Author: ["Henrik Mikael Kristensen"]
  Copyright: "2006 - HMK Design"
  Created: 2006-01-31
  Date: 2006-02-02
  Version: 0.0.4
  License: {
    BSD (www.opensource.org/licenses/bsd-license.php)
    Use at your own risk.
  }
  Purpose: {Relations Engine to relate values and data with each other}
  Note: {
    This file is available at:
    http://www.hmkdesign.dk/rebol/list-view/relations.r
    Docs are available in makedoc2 format at:
    http://www.hmkdesign.dk/rebol/relationsengine/relations.txt
    http://www.hmkdesign.dk/rebol/relationsengine/relations.html
    http://www.hmkdesign.dk/rebol/relationsengine/relations-history.txt
    http://www.hmkdesign.dk/rebol/relationsengine/relations-history.html
  }
  History: [
    See: http://www.hmkdesign.dk/rebol/relationsengine/relations-history.html
  ]
]

relations: make object! []

get-relation: func [
  "Gets a relation from the relations object"
  block [block!] "Path block (will be reduced)"
  /plain "Output a block for internal use in ADD-RELATIONS and REMOVE-RELATIONS"
  /each word [word!] "Select a word to get for each of the block values"
  /pair "Pair up the gotten words with their parent values. Works only with /each"
  /local flag tmp tmp2 parent-tmp error rel-obj
] [
  rel-obj: relations
  stop: func [/noflag][
    if all [plain not noflag] [flag: index? block]
    if not noflag [break]
  ]
  block: compose block
  flag: none
  tmp: rel-obj
  forall block [
    either any [
      all [odd? index? block not word? first block]
      all [
        even? index? block
        any [
          object? first block
          word? first block
          block? first block
        ]
      ]
    ] [
      error: true break
    ][
      if not object? tmp [parent-tmp: tmp]
      tmp: either word? block/1 [
        either object? tmp [
          either tmp2: get in tmp block/1 [tmp2][
            flag: index? block
            stop
          ]
        ][
          either empty? tmp [stop][
            either object? first tmp [
              get in first tmp block/1
            ][
              either 1 = index? block [
                either in tmp block/1 [get in tmp block/1][stop]
              ][
                either tmp2: find tmp block/1 [first next reduce tmp2][stop]
              ]
            ]
          ]
        ]
      ][
        either object? tmp [
          either word? block/1 [get in tmp block/1][stop]
        ][
          either tmp2: find tmp block/1 [
            either tail? next tmp2 [
              either tail? next block [break][tmp2]
            ][
              either object? first next reduce tmp2 [
                first next reduce tmp2
              ][
                either tail? next block [break][tmp2]
              ]
            ]
          ][
            either tmp2: find tmp block/1 [tmp2][
              flag: index? block
              stop
            ]
          ]
        ]
      ]
    ]
  ]
  either error [false][
    either each [
      forall tmp [
        append [] either all [not tail? next val object? second val] [
          get in second val word
        ][none]
        tmp: next tmp
      ]
    ][
      either plain [reduce [flag tmp parent-tmp]][
        either flag [none][
          either block? tmp [remove-each i reduce tmp [object? i]][
            either object? tmp [next first tmp][tmp]]
        ]
      ]
    ]
  ]
]

add-relation: func [
  "Adds one or more relations to the relations object"
  block [block!] "Path block (will be reduced)"
  /local d flag point parent-point obj-point p val error
] [
  error: false
  either d: get-relation/plain block [
    block: compose block
    set [flag point parent-point] d
    obj-point: none
    if flag [
      foreach value at block flag [
        either all [even? flag word? pick block flag] [error: true break][
          if word? value [val: compose [(to-set-word value) copy []]]
          either flag = 1 [
            if not in point value [relations: make point val]
            obj-point: get in relations value
          ][
            either word? value [
              if not all [
                not obj-point
                p: find parent-point pick block flag - 1
                obj-point: next p
              ] [
                obj-point: either obj-point [obj-point][parent-point]
              ]
              either tail? obj-point [
                insert tail obj-point make object! val
              ][
                either object? first obj-point [
                  change obj-point make first obj-point val
                ][
                  if any [
                    tail? obj-point
                    not object? attempt [first obj-point]
                  ] [insert obj-point make object! val]
                ]
              ]
            ][
              if not all [
                not obj-point
                p: find parent-point pick block flag - 1
                obj-point: next p
              ] [
                obj-point: either obj-point [obj-point][parent-point]
              ]
              if not find obj-point value [insert tail obj-point value]
            ]
            if not tail? next at block flag [
              obj-point: either object? first obj-point [
                get in first obj-point pick block flag
              ][
                next find obj-point pick block flag
              ]
            ]
          ]
          flag: flag + 1
        ]
      ] not error
    ]
  ][false]
]

remove-relation: func [
  "Removes a single relation or a full branch of relations from the relations object."
  block "Block path to the relation to remove (will be reduced)"
  /local d flag point parent-point obj-point p
] [
  either d: get-relation/plain block [
    block: compose block
    set [flag point parent-point] d
    either word? last block [
      obj-point: either parent-point [
        either p: find parent-point last block [next p][parent-point]
      ][
        either object? point [
          either p: get in point last block [next p][point]
        ][
          either p: find point last block [next p][point]
        ]
      ]
      either parent-point [
        if obj-point: find obj-point first back back tail block [
          change next obj-point
            make object! remove remove
              find third second obj-point to-set-word last block
        ]
      ][
        if in relations last block [
          relations: make object!
            remove remove find third relations to-set-word last block
        ]
      ]
    ][
      p: find either object? point [parent-point][point] last block
      if p [either object? second p [remove remove p][remove p]]
    ]
  ][false]
]

replace-relation: func [
  "Replaces a relation value or word in the relations object."
  block [block!] "Path block with the old value to replace as the last element"
  value "New value to insert at the last element in the path block"
  /local flag point parent-point p d
] [
  either d: get-relation/plain block [
    block: compose block
    set [flag point parent-point] d
    either all [even? length? block word? last block] [false][
      either flag = 1 [false][
        either parent-point [
          either object? point [
            either all [
              not find parent-point value
              find parent-point last block
            ] [change find parent-point last block value][false]
          ][
            either even? length? block [
              either all [
                not find point value
                find point last block
              ] [change find point last block value][false]
            ][
              p: find parent-point first back back tail block
              either object? first next p [
                change next p make object!
                  replace third first next p
                    to-set-word last block to-set-word value
              ][false]
            ]
          ]
        ][
          either in relations value [false][
            relations: make object! replace
              third relations to-set-word last block to-set-word value
          ]
        ]
      ]
    ]
  ][false]
]