#lang scheme

(require (prefix-in general: "general.ss"))
(require "engine-interface.ss")

(define (flat->nested dimensions vector)
  (if 
   (null? dimensions) vector
   ; the last member of dimensions is only good for validation... vector should already be that size!
   (let travel-down ([dimensions (cdr (reverse dimensions))] [vector vector])
    (if 
     (null? dimensions) vector
     (let ([dimension (car dimensions)])
       (travel-down 
        (cdr dimensions)
        (let collate ([vector vector] [left dimension] [row null] [result null])
          (cond 
            [(null? vector) (reverse (cons (reverse row) result))]
            [(> left 0) (collate (cdr vector) (- left 1) (cons (car vector) row) result)]
            [else (collate vector dimension null (cons (reverse row) result))]))))))))

(define (bytes-split-sizes bytes) ; where the sizes are embedded in the bytes
  (let loop ([bytes bytes] [result null])
    (if (= (bytes-length bytes) 0) (reverse result)
        (let ([size (integer-bytes->integer bytes #t #t 0 4)])
          (loop (subbytes bytes (+ size 4)) (cons (subbytes bytes 4 size) result))))))

(define (bytes-extract-dimensions bytes num)
  (let loop ([bytes bytes] [dimensions null] [lbounds null] [left num])
    (if (<= left 0) (values (reverse dimensions) (reverse lbounds) bytes)
        (call-with-values
         (λ () (general:bytes-extract-header '(4 4) bytes))
         (λ (dimension lbound bytes)
           (loop bytes (cons dimension dimensions) (cons lbound lbounds) (- left 1)))))))

(define (decode-vector engine element-oid bytes)
  (let-values
      ([(n-dimensions hasnull type bytes) (general:bytes-extract-header `(4 4 ,(get-field oid-size engine)) bytes)])
    (let-values
        ([(dimensions lbounds bytes) (bytes-extract-dimensions bytes n-dimensions)])
      (flat->nested (map (λ (item) (send engine decode element-oid item)) (bytes-split-sizes bytes))))))

(define (determine-dimensions vector [result null])
  (if (not (list? vector)) (reverse result)
      (determine-dimensions (car vector) (cons (length vector) result))))

(define (encode-vector engine element-oid value)
  (let ([flags 0] ; it does... absolutely nothing with these. 1 is also valid, others are error.
        [dimensions (determine-dimensions value)])
    (apply 
     bytes-append
     (flatten
      (list
       (map (λ (i) (integer->integer-bytes i 4 #t #t)) (list (length dimensions) flags))
       (integer->integer-bytes element-oid (get-field oid-size engine) #t #t)
       (map (λ (i) (integer->integer-bytes i 4 #t #t) (integer->integer-bytes 0 4 #t #t)) ; lowest offset is always from 0 right?
            dimensions)
       (map (λ (item) 
              (let ([bytes (send engine encode element-oid item)])
                (bytes-append (general:encode-int4 (bytes-length bytes)) bytes)))
            (flatten value)))))))

(define (decode-fixed-vector engine element-oid bytes length)
  (let ([cell-size (/ (bytes-length bytes) length)])
    (let loop ([bytes bytes] [result null])
      (if (= (bytes-length bytes) 0) (reverse result)
          (loop (subbytes bytes cell-size)
                (cons (send engine decode element-oid (subbytes bytes 0 cell-size)) result))))))
  
(define (encode-fixed-vector engine element-oid cells length)
  (subbytes (bytes-append (map (λ (value) (send engine encode element-oid value)) cells)) 0 length))

(define-syntax this-or
  (syntax-rules ()
    [(_ a b) 
     (let ([result a])
       (if result result b))]))

(define (divine engine value)
  (if (not (list? value)) #f
      (let ([element-oid
             (let loop ([l value])
               (let ([item (car l)])
                 (if (list? item) (loop item)
                     (send engine divine item))))])
        (this-or
         (send engine vector-oid-for element-oid)
         (error "Could not find an oid for list ~s type ~s~n" value element-oid)))))

(define (set-info! oid element-oid length engine)
  (let ([encode 
         (if length 
             (λ (value)
               (encode-fixed-vector engine element-oid length value))
             (λ (value)
               (encode-vector engine element-oid value)))]
        [decode 
         (if length 
             (λ (bytes)
               (decode-fixed-vector engine element-oid bytes length))
             (λ (bytes)
               (decode-vector engine element-oid bytes)))])
    (send engine set-codec! oid encode decode))
  (send engine add-diviner! (λ (value) (divine engine value))))

; 9.3.13
; (01:51:15 PM) RhodiumToad: synx: if typelem is not InvalidOid then it's an array-like type. if typlen is >0, then it's a fixed-length array (just some number of elements in sequence), if typlen is < 0 it's a varlena array, with the header with the element type and dimension info

(provide/contract
 [set-info! (integer? integer? (or/c integer? false?) engine? . -> . void?)])