(library (sph storage dg relation path-find)
  (export
    dg-path-find
    dg-path-find-combinators
    dg-path-find-delete
    dg-path-find-delete->targets)
  (import
    (rnrs exceptions)
    (sph)
    (sph storage dg)
    (sph storage dg one)
    (sph storage dg relation path-find base)
    (sph storage dg relation path-find node)
    (sph storage dg relation path-find path)
    (srfi srfi-41)
    (only (guile) vector-copy)
    (only (rnrs lists) partition)
    (only (srfi srfi-1) delete-duplicates last))

  (define sph-storage-dg-relation-path-find-description
    "path-find: find relations that match expressions like \"all nodes that are right of all of some nodes\".
     path expression examples:
       (1 * 2)
       ((only 14 15) *)
       ((and 11 12) (not 24) (or 32 31))
       ((and 11 12) (not 24) (or (not (and 41)) (or 32 31) 32 31))
     path expression syntax:
       path: skip/node ..1
       node: (combinator id/node ..1)
       combinator: and/or/only/not
       skip: */(* integer:max [integer:min])
       id: integer
     other:
       s: source, t: target, r: retrieve/result
       get-relations :: (integer ...):source (integer ...):target symbol:retrieve-field-name
       directional-arguments: (procedure:get-relations procedure:result-get-relations symbol:target-field-name procedure:target-field-accessor)
       negative combinators (rejections): not
     notes:
       path-find at first did not use streams and now uses streams in some places,
       utilised might not be utilised as effectively as they might, particularly when preparing the next \"from\" values of a path,
       where the whole stream is read
     evaluation strategy - example:
       (and (or 1 2) (or 3 4)) (or (and 5 6) (and 7 8))
       (or 3 4) (7 8) -> stream
       stream (and 7 8) -> stream
       (and (or 1 2) (or 3 4)) (or (and 5 6) stream)
       (or 3 4) (5 6) -> stream
       stream (and 5 6) -> stream
       (and (or 1 2) (or 3 4)) (or stream stream)
       (or stream stream) -> stream
       (and (or 1 2) stream) (or (and 5 6) (and 7 8))
       (or 1 2) (7 8) -> stream
       stream (and 7 8) -> stream
       (and (or 1 2) stream) (or (and 5 6) stream)
       (or 1 2) (5 6) -> stream
       stream (and 5 6) -> stream
       (and (or 1 2) stream) (or stream stream)
       (or stream stream) -> stream
       (and stream stream) -> stream
       stream
     evaluation with negation/\"not\" - example:
       (not (or 1 2)) (not (and 5 6))
       (or 1 2) #f -> non-targets
       #f (not (and 5 6)) -> possible-targets
       (not stream) -> stream  -- possible-targets made available to not-consume")

  (define default-end-distance 1)
  (define default-skip-expr (vector default-end-distance #f #f))

  (define (map-node-expression a proc-consume proc-get)
    "list:node-expr procedure:{symbol (relation-record-stream ...) boolean:negative -> relation-record-stream} procedure:{symbol (integer ...) boolean:negative -> relation-record-stream} -> relation-record-stream
     map lists bottom to top, passing lists of either only results or only ids to the procedures proc-consume and proc-get respectively"
    (let
      (proc
        (l (a negative)
          (let-values (((id-list results) (partition integer? (tail a))) ((combinator) (first a)))
            (if (null? id-list)
              (if (null? results) stream-null (proc-consume combinator results negative))
              (if (null? results) (proc-get combinator id-list negative)
                (proc-consume combinator (pair (proc-get combinator id-list negative) results)
                  negative))))))
      (proc
        (let loop ((a a) (negative (negative-expression? a)))
          (map
            (l (a) (if (list? a) (proc (loop a (or negative (negative-expression? a))) negative) a))
            a))
        #f)))

  (define (directional-arguments-invert arguments)
    "(procedure:get-relations procedure:result-get-relations symbol:field-name procedure:field-accessor) -> (procedure procedure symbol procedure):inverted-versions
     reverses the argument order of procedures and chooses the opposite field-name and field-accessor"
    (apply
      (l (get-relations result-get-relations field-name field-accessor)
        (list (get-relations-invert get-relations)
          (result-get-relations-invert result-get-relations) (dg-direction-invert field-name)
          (dg-direction-field-accessor-invert field-accessor)))
      arguments))

  (define
    (produce-node-expressions source target directional-arguments directional-arguments-inverted)
    "list:node-expr list/false:node-expr list list -> stream"
    ;when the sub-expressions of two node expressions are produced, either:
    ; * ids from both sides have to be evaluated (-get, stream with database access created)
    ; * ids from one side still have to be evaluated for a result from the other side (-consume-one)
    ; * all ids for the current nesting level have already been evaluated and a combinator is to be applied to results (-consume)
    (letrec*
      ( (consume-proc
          (l (target directional-arguments directional-arguments-inverted)
            "false/list:node-expr list list -> stream"
            (l (combinator results negative)
              (apply (node-combinator->consume combinator) results
                (append directional-arguments
                  (list
                    (and (negative-combinator? combinator) target
                      (produce-node-expressions target #f
                        directional-arguments-inverted directional-arguments))))))))
        (get
          (l (combinator s t) (apply (node-combinator->get combinator) s t directional-arguments))))
      (map-node-expression source
        (consume-proc target directional-arguments directional-arguments-inverted)
        (if target
          (l (source-combinator s negative)
            (if negative (get source-combinator s #f)
              (map-node-expression target
                (consume-proc source directional-arguments-inverted directional-arguments)
                (l (target-combinator t negative)
                  (apply (node-combinator->consume-one target-combinator)
                    (get source-combinator s t) t directional-arguments-inverted)))))
          (l (source-combinator s negative) (get source-combinator s #f))))))

  (define (eval-node-expressions s t directional-arguments directional-arguments-inverted)
    "list/false:node-expr list/false:node-expr procedure procedure symbol procedure:{vector -> any} -> any
     evaluates two node expressions"
    (if s (produce-node-expressions s t directional-arguments directional-arguments-inverted)
      (if t (produce-node-expressions t #f directional-arguments-inverted directional-arguments)
        (raise (q path-find-unsupported-case)))))

  (define (skip-expr? a) "any -> boolean"
    (or (eq? (q *) a) (and (list? a) (not (null? a)) (eq? (q *) (first a)))))

  (define (parse-skip-expr node-expr)
    "list/symbol -> vector
     input must be a valid skip-expr"
    (if (list? node-expr)
      (let (r (vector-copy default-skip-expr))
        (let next ((rest (tail node-expr)) (cur-index 0))
          (if (null? rest) r
            (begin (vector-set! r cur-index (first rest)) (next (tail rest) (+ 1 cur-index))))))
      default-skip-expr))

  (define (direction->get-relations-procedures& a txn label c)
    "symbol dg-txn list procedure:{procedure procedure -> any}
     wrap txn and label, adjust argument order and call (c get-relations result-get-relations)"
    (if (eq? (q left) a)
      (c (get-relations-invert (get-relations-proc txn label)) result-get-relations)
      (c (get-relations-proc txn label) result-get-relations)))

  (define (direction->eval-node-expressions* a txn label)
    "procedure procedure -> procedure:{list/false:node-expr/from list/false:node-expr/to -> any}
     wraps get-relations, result-get-relations, field-name and field-accessor to have an eval-node-expressions that only takes (from to)"
    (let (field-accessor (dg-direction->field-accessor a))
      (direction->get-relations-procedures& a txn
        label
        (l (get-relations result-get-relations)
          (let*
            ( (directional-arguments (list get-relations result-get-relations a field-accessor))
              (directional-arguments-inverted (directional-arguments-invert directional-arguments)))
            (l (from to)
              (eval-node-expressions from to directional-arguments directional-arguments-inverted)))))))

  (define dg-path-find-eval-path
    (letrec
      ( (skip-start-distance
          (l (eval-node-expressions* from start-distance)
            "procedure list:node-expr integer -> list
            skip at least start-distance intermediate nodes or until no matches are returned"
            (if (or (null? from) (= 0 start-distance)) from
              (skip-start-distance eval-node-expressions* (eval-node-expressions* from #f)
                (- start-distance 1)))))
        (with-end-distance
          (l (eval-node-expressions* from to end-distance result prepare-next-source)
            "procedure list list integer -> list
            skip intermediate nodes by accepting any result as matches at most end-distance times until a matching target is found"
            (let* ((from (prepare-next-source from)) (r (eval-node-expressions* from to)))
              (if (null? from) result
                (if (< end-distance 2) (stream-append result r)
                  (with-end-distance eval-node-expressions* (eval-node-expressions* from #f)
                    to (- end-distance 1)
                    (if (null? r) result (stream-append result r)) prepare-next-source))))))
        (proc-apply
          (l (proc from to skip)
            "procedure list/false list/false vector/false -> any
            apply proc with from and to and separated start/end skip values"
            (apply proc from
              to
              (if skip (list (vector-ref skip 0) (vector-ref skip 1))
                (list default-end-distance #f)))))
        (loop
          (l (proc rest from to skip)
            "procedure list/false:node-expr list/false:node-expr vector/falso:skip-expr -> any
            sets from to the result of applying proc"
            (if (null? rest) (if skip (proc-apply proc from to skip) from)
              (let (a (first rest))
                (if (skip-expr? a)
                  ;parse and set skip
                  (loop proc (tail rest) from to (parse-skip-expr a))
                  (if (or skip from)
                    ;apply proc if skip or from is set
                    (loop proc (tail rest) (proc-apply proc from a skip) #f #f)
                    (loop proc (tail rest) a to skip)))))))
        (prepare-next-source-proc
          (l (field-accessor)
            (l (a)
              (if (stream? a)
                (pair dg-path-find-default-combinator
                  (delete-duplicates (stream->list (stream-map field-accessor a))))
                a)))))
      (l (txn path label direction)
        "list dg-txn false/list symbol -> stream:relation-record-stream
        evaluate a path-find path expression"
        (let
          ( (eval-node-expressions* (direction->eval-node-expressions* direction txn label))
            (prepare-next-source
              (prepare-next-source-proc (dg-direction->field-accessor direction))))
          (loop
            (l (from to end-distance start-distance)
              (let*
                ( (from (prepare-next-source from))
                  (from
                    (if start-distance
                      (skip-start-distance eval-node-expressions* from start-distance) from)))
                (with-end-distance eval-node-expressions* from
                  to end-distance stream-null prepare-next-source)))
            path #f #f #f)))))

  (define* (dg-path-find txn path #:optional retrieve label (direction (q right)))
    "dg-txn list [symbol list symbol] -> error/list
     matches set relation paths like the following, and returns targets or target relations:
       ((and 11 12) (not 24) (or (all 41) (not 42) (or 32 31) 32 31))
       (1 *)
       (1 * 2)"
    (and-let* ((path (dg-path-find-path-prepare path)))
      (if (null? path) stream-null
        (let (r (dg-path-find-eval-path txn path label direction))
          (if retrieve
            (let (accessor (dg-relation-field-name->accessor retrieve)) (stream-map accessor r)) r)))))

  (define* (dg-path-find-delete txn path #:optional label (direction (q right)))
    "dg-txn list [false/(integer ...) symbol:left/right] -> (vector ...)
     delete target relations by path-find-path"
    (let (relations (stream->list (dg-path-find txn path #f label direction)))
      (dg-relation-delete txn (map dg-relation-record-left relations)
        (map dg-relation-record-right relations) label)
      relations))

  (define (dg-path-find-delete->targets . dg-path-find-delete-arguments)
    "symbol list -> (id ...)
     delete target relations matching path and return the targets as retrieved with path-find"
    (map (dg-direction->field-accessor (last dg-path-find-delete-arguments))
      (apply dg-path-find-delete dg-path-find-delete-arguments))))