(library (sph storage dg one)
  (export
    dg-bytevector->id
    dg-bytevector->ids
    dg-bytevector->type
    dg-default-read-count
    dg-delete-disconnected
    dg-delete-disconnected-with-ignore
    dg-delete-relations->targets
    dg-direction->field-accessor
    dg-direction-field-accessor-invert
    dg-direction-invert
    dg-direction-left?
    dg-disconnected-with-ignore?
    dg-disconnected?
    dg-filter-disconnected
    dg-id->type-string
    dg-id->type-symbol
    dg-ids->bytevector
    dg-ids->left-interns
    dg-intern-ensure-one
    dg-mtime
    dg-relation-ensure-map
    dg-relation-ensure-one
    dg-relation-ensure-ordered
    dg-relation-field-name->accessor
    dg-replace-left
    dg-vector
    dg-vector-from-data
    dg-vector-id->data
    dg-vector-id->data-id)
  (import
    (guile)
    (rnrs bytevectors)
    (rnrs eval)
    (sph)
    (sph list)
    (sph record)
    (sph storage dg)
    (sph storage dg implicit-txn)
    (only (srfi srfi-1) delete-duplicates))

  (define dg-default-read-count 512)

  (define dg-ids->bytevector
    ; for storing node identifiers in bytevectors.
    ; might not work for id types that are not integers between 8-64 bit
    (case dg-size-octets-id ((8) list->u64vector)
      ((4) list->u32vector) ((2) list->u16vector) ((1) list->u8vector) (else (q unsupported-id-size))))

  (define dg-bytevector->ids
    (case dg-size-octets-id ((8) u64vector->list)
      ((4) u32vector->list) ((2) u16vector->list) ((1) u8vector->list) (else (q unsupported-id-size))))

  (define (bytevector->u8 a) (bytevector-u8-ref a 0))
  (define (bytevector->u16 a) (bytevector-u16-native-ref a 0))
  (define (bytevector->u32 a) (bytevector-u32-native-ref a 0))
  (define (bytevector->u64 a) (bytevector-u64-native-ref a 0))

  (define dg-bytevector->id
    (case dg-size-octets-id ((8) bytevector->u8)
      ((4) bytevector->u32) ((2) bytevector->u16) ((1) bytevector->u8) (else (q unsupported-id-size))))

  (define native-endianness* (native-endianness))

  (define (dg-bytevector->type a type)
    (case type ((string) (utf8->string a))
      ((integer) (bytevector-sint-ref a 0 native-endianness* (bytevector-length a))) (else a)))

  (define (dg-vector-id->data-id txn ids)
    "dg-txn (integer ...) -> false/(integer ...)
     get the ids in vector as a list"
    (and-let* ((data (dg-intern-id->data txn ids (q bytevector) #t))) (map dg-bytevector->ids data)))

  (define (dg-vector-id->data txn ids)
    "integer (symbol:dg-intern-id->data-read-type ...) -> false/(any ...)
     get the referenced data of dg-vector in order"
    (let
      (get-data (l (data-ids) (and-let* ((data (dg-intern-id->data txn data-ids))) (reverse data))))
      (every-map get-data (dg-vector-id->data-id txn ids))))

  (define (dg-vector-from-data txn . a)
    "dg-txn any ... -> integer
     ensure a dg-vector with the given data in order exists and return its id"
    (apply dg-vector txn (reverse (dg-intern-ensure txn a))))

  (define (dg-vector txn . element-ids)
    "dg-txn integer ... -> integer
     ensure a dg-vector with the given element-ids in order exists and return its id.
     vectors are interns that store node-ids in order. they use less space and are faster to retrieve than for example sets
     but the values are not automatically indexed"
    (first (dg-intern-ensure txn (list (dg-ids->bytevector element-ids)))))

  (define (dg-any->data-read-type a)
    "any -> symbol
     return the appropriate read-type for dg-intern-id->data for the given value"
    (cond ((bytevector? a) (q bytevector)) ((integer? a) (q integer))
      ((string? a) (q string)) (else (q scheme))))

  (define (dg-list->data-read-types a)
    "(any ...) -> (symbol ...)
     like dg-any->data-read-type but for every value in a list"
    (map dg-any->data-read-type a))

  (define (dg-mtime) (stat:mtime (stat (string-append (dg-root) "/data"))))

  (define (dg-id->type-symbol a) "integer -> symbol/false"
    (or (and (dg-intern? a) (q intern)) (and (dg-extern? a) (q extern)) (and (dg-id? a) (q id))))

  (define (dg-id->type-string a) "integer -> string/false"
    (or (and (dg-intern? a) "intern") (and (dg-extern? a) "extern")
      (and (dg-id? a) "id") (and (dg-intern-small? a) "intern-small")))

  (define-syntax-case (dg-init-define-interns name/data ...) s
    ; ! deprecated. modifying the database on module load happens even when features of
    ;   the library are only optionally supported
    ; defines variables set to a list with the id of the specified data.
    ; the id is in a list because these interns are often used as one label in queries
    ; and dg query procedures usually expect lists.
    ; example
    ;   (dg-init-define-interns ids-intern-name "name" ids-intern-test "test")
    (let*
      ( (name/data-datum
          (map-slice 2 (l a (apply pair a)) (syntax->datum (syntax (name/data ...)))))
        (names (map first name/data-datum))
        (data-list (datum->syntax s (list (q q) (map tail name/data-datum))))
        (define-names (datum->syntax s (map (l (a) (list (q define) a)) names)))
        (names-list (datum->syntax s (list (q q) names))))
      (quasisyntax
        (begin (import (only (rnrs base) set!)) (unsyntax-splicing define-names)
          (dg-init-extension-add
            (let
              ((names (unsyntax names-list)) (data (unsyntax data-list)) (module (current-module)))
              (nullary
                (let (ids (dg-txn-call-write (l (txn) (dg-intern-ensure txn data))))
                  (eval
                    (pair (q begin)
                      (map (l (name id) (list (q set!) name (list (q list) id))) names
                        (reverse ids)))
                    module)))))))))

  (define (dg-relation-ensure-one txn left right) (dg-relation-ensure txn (list left) (list right)))

  (define (dg-relation-field-name->accessor a) "symbol -> procedure:dg-record-accessor"
    (case a ((right) dg-relation-record-right)
      ((left) dg-relation-record-left) ((label) dg-relation-record-label)
      ((ordinal) dg-relation-record-ordinal)))

  (define-syntax-rule (dg-direction->field-accessor a)
    (if (dg-direction-left? a) dg-relation-record-left dg-relation-record-right))

  (define-syntax-rule (dg-direction-field-accessor-invert a)
    (if (eq? a dg-relation-record-left) dg-relation-record-right dg-relation-record-left))

  (define-syntax-rule (dg-direction-invert a) (if (eq? (q right) a) (q left) (q right)))
  (define-syntax-rule (dg-direction-left? a) (eq? (q left) a))

  (define (dg-relation-ensure-map txn left right)
    "(integer ...) -> (integer ...)
     ensure relations from each same index of list \"left\" and \"right\""
    (apply append
      (map (l (left right) (dg-relation-ensure txn (any->list-s left) (any->list-s right))) left
        right)))

  (define* (dg-ids->left-interns txn ids #:optional (label (list 0)) (retrieve (q bytevector)))
    "dg-txn (integer ...) symbol -> list"
    (dg-intern-id->data txn
      (let*
        ( (selection (dg-relation-select txn #f ids label (q left)))
          (read (nullary (filter dg-intern? (dg-relation-read selection dg-default-read-count)))))
        (let loop ((data (read))) (if data (append data (loop (read))) data)))
      retrieve))

  (define* (dg-replace-left txn ids label new #:optional old)
    "dg-txn nodes:(integer ...) false/(integer ...) new-left-ids:(integer ...) [old-left-ids:(integer ...)] -> (old new)
     does not delete nodes"
    (apply
      (l (new old) (if old (dg-relation-delete txn old ids label))
        (if new (dg-relation-ensure txn new ids label)) (list old new))
      (complement-both new (if old old (dg-relation-select-read txn #f ids label (q left))))))

  (define* (dg-disconnected? txn ids #:optional label direction)
    "dg-txn list list direction:[boolean/symbol] -> boolean
     direction: left/right/false:both
     true if all given node ids have no relations"
    (and
      (if (or (not direction) (eq? (q left) direction))
        (null? (dg-relation-select-read txn #f ids label (q left))) #t)
      (if (or (not direction) (eq? (q right) direction))
        (null? (dg-relation-select-read txn ids #f label (q left))) #t)))

  (define* (dg-delete-disconnected txn ids #:optional label direction)
    "dg-txn list:(integer ...) [list false/symbol] -> list:(integer ...):ids-deleted
     delete ids which are not included in any relations"
    (let (disconnected (filter (l (a) (dg-disconnected? txn (list a) label direction)) ids))
      (dg-delete txn disconnected) disconnected))

  (define* (dg-disconnected-with-ignore? txn ids ignore #:optional label direction)
    "false/symbol] -> boolean
     symbol: left/right
     like dg-disconnected? but allows to ignore related identifiers in relations.
     nodes are disconnected if they have no relations or are only in relations with ignored ids"
    (and
      (if (or (not direction) (eq? (q left) direction))
        (let (left (dg-relation-select-read txn #f ids label (q left)))
          (or (not left) (contains-all? ignore left)))
        #t)
      (if (or (not direction) (eq? (q right) direction))
        (let (right (dg-relation-select-read txn ids #f label (q right)))
          (or (not right) (contains-all? ignore right)))
        #t)))

  (define* (dg-delete-disconnected-with-ignore txn ids label ignore #:optional direction)
    "dg-txn list list list boolean/symbol -> list:ids-deleted
     like dg-delete-disconnected but selects nodes like dg-disconnected-with-ignore?"
    (let
      (disconnected
        (filter (l (e) (dg-disconnected-with-ignore? txn (list e) ignore label direction)) ids))
      (dg-delete txn disconnected) disconnected))

  (define* (dg-delete-relations->targets txn direction left #:optional label right)
    "dg-txn symbol list [false/list list] -> list
     delete matching relations and return the left or right ids depending on the direction"
    (let (r (dg-relation-select-read txn left right label direction))
      (dg-relation-delete txn left right label) (delete-duplicates r)))

  (define* (dg-filter-disconnected txn ids #:optional label direction)
    "[false/list false:both/symbol:left/right] -> list
     remove from \"ids\" those which are not contained in any relation in direction"
    (if direction
      (if (eq? (q left) direction)
        (complement ids (dg-relation-select-read txn #f ids label (q right)))
        (complement ids (dg-relation-select-read txn ids #f label (q left))))
      (let (left (complement ids (dg-relation-select-read txn #f ids label (q right))))
        (if (null? left) left (complement ids (dg-relation-select-read txn ids #f label (q left))))))))