;; Transparent naive ((alist) . vector) records without type-train. BSD-2-Clause licence
;; Author: Anton Idukov corbas.ai@gmail.com

;; So just create record
;; > (define r (record-vector #:x 1.0 #:y 3.0))
;; > r => (((#:x . 0) (#:y . 1)) . #(1.0 3.0))

;; Clone
;; > (define r2 (record-vector-clone r #:y 2.0 #:z 3.0))
;; > r2 => (((#:x . 0) (#:y . 1) (#:z . 2)) . #(1.0 2.0 3.0))

;; Get field
;; > (record-vector-ref r #:y) => 3.0
;; > (record-vector-ref r2 #:y) => 2.0

;; Get field by index
;; > (record-vector-ref r 1) => 3.0

;; Update
;; > (record-vector-update! r2 #:z 3.3)
;; > r2 => (((#:x . 0) (#:y . 1) (#:z . 2)) . #(1.0 2.0 3.3))

;; Thereis shortcomings rv-* for record-vector-* procedures
;; rector-vector
;; rv-upd! = record-vector-update
;; rv-clone = record-vector-clone
;; rv-attr? = record-vector-attr?
;; (!)  rv-set! is macro over record-vector-set!
;; (!)  rv-ref is macro over record-vector-ref

;; Mutate
;; > (rv-set! r2 #:x 555)
;; > r2 => (((#:x . 0) (#:y . 1) (#:z . 2)) . #(555 2.0 3.3))

;; Chain rv-set!/rv-ref
;; > (define rt (record-vector name: "rt" prop: r2))
;; > (rv-set! rt prop: z: 4.4)
;; > rt => (((#:name . 0) (#:prop . 1)) . #("rt" (((#:x . 0) (#:y . 1) (#:z . 2)) . #(555 2.0 4.4))))
;; > (rv-ref rt prop:) => (((#:x . 0) (#:y . 1) (#:z . 2)) . #(555 2.0 4.4))
;; > (rv-ref rt prop: z:) => 4.4
;; Also by reference property by index
;; > (rv-set! rt 1 2 88.88)
;; bc index of #:prop in rt is 1 (bc #:name is 0). index of #:z in r2 record is 2
;; > (rv-ref rt 1 2) => 88.88

;; Mutate in SRFI-17 way only with record-vector-ref form (rv-set! is macros)
;; > (set! (record-vector-ref r2 #:x) (* (rv-ref r2 #:x) 10))
;; > r2 => (((#:x . 0) (#:y . 1) (#:z . 2)) . #(5550 2.0 3.3))

;; *set! form is not extends record
;; > (set! (record-vector-ref r2 #:t) 4.0) => Error: (cdr) bad argument type: #f
;;                              (#f from assq on (car r2))

;; Check attribute presence
;; > (rv-attr? r2 #:t) => #f
;; > (rv-attr? r2 #:x) => (#:x . 0)
;; > (rv-attr? (rv-ref rt #:prop) #:z) => (#:z . 2)


;; Self length
;; > (rv-len r) => 2
;; > (rv-len r2) => 3
;; > (rv-update! r2 #:t 7e10)
;; > (rv-len r2) => 4


;; construct

(define record-vector
  (lambda r
    (let loop ((defs r) (i 0) (vals '()) (kws '()))
      (cond ((null? defs)
             (cons (reverse kws) (list->vector (reverse vals))))
            (else
             (cond ((and (keyword? (car defs)) (pair? (cdr defs)) (not (keyword? (cadr defs))))
                    (loop (cddr defs) (+ 1 i) (cons (cadr defs) vals) (cons (cons (car defs) i) kws)))
                   (else (error "unmatched keyword in " r))))))))

(define make-rv record-vector)


;; len

(define (record-vector-length rv)
  (vector-length (cdr rv)))

(define rv-len record-vector-length)


;; test predicate

(define (record-vector? rv)
  (and (pair? rv) (list? (car rv)) (vector? (cdr rv))))


;; access

(define (record-vector-ref rv index . default)
  (if (exact-integer? index)
      (vector-ref (cdr rv) index)
      (cond ((assq index (car rv)) => (lambda (ix) (vector-ref (cdr rv) (cdr ix))))
            (else (or (and (pair? default) (car default)) #f)))))

(define-syntax rv-ref
  (syntax-rules ()
    ((_ r prop) (record-vector-ref r prop))
    ((_ r prop1 prop2 ...)
     (rv-ref (record-vector-ref r prop1) prop2 ...))))

(define (rv-ref* r prop . props)
  (cond ((null? props) (record-vector-ref r prop))
        (else (apply rv-ref* (record-vector-ref r prop) props))))


;; update (mutate!)

(define (record-vector-update! rv index value)
  (cond ((exact-integer? index)
         (vector-set! (cdr rv) index value))
        (else
         (cond ((assq index (car rv)) => (lambda (i) (vector-set! (cdr rv) (cdr i) value)))
               (else (set-car! rv (reverse
                                   (cons (cons index (vector-length (cdr rv)))
                                         (reverse (car rv)))))
                     (set-cdr! rv (vector-append (cdr rv) (vector value))))))))

(define-syntax rv-update!
  (syntax-rules ()
    ((_ r prop val) (record-vector-update! r prop val))
    ((_ r prop1 prop2 val)
     (record-vector-update! (record-vector-ref r prop1) prop2 val))
    ((_ r prop1 prop2 ...)
     (rv-update! (record-vector-ref r prop1) prop2 ...))))


;; check for attribute presence

(define (record-vector-attr? rv k)
  (assq k (car rv)))

(define rv-attr? record-vector-attr?)


;; setter (mutate!)

(define (record-vector-set! rv index value)
  (cond ((exact-integer? index)
         (vector-set! (cdr rv) index value))
        (else (vector-set! (cdr rv) (cdr (assq index (car rv))) value))))

(define-syntax rv-set!
  (syntax-rules ()
    ((_ r prop val) (record-vector-set! r prop val))
    ((_ r prop1 prop2 val)
     (record-vector-set! (record-vector-ref r prop1) prop2 val))
    ((_ r prop1 prop2 ...)
     (rv-set! (record-vector-ref r prop1) prop2 ...))))


;; clone (copying [with mutations])

(define (record-vector-clone src . r)
  (define (record-copy rvec)
    (do ((i 0 (+ i 1)) (newvec (make-vector (vector-length rvec))))
        ((= i (vector-length newvec)) newvec)
      (let ((val (vector-ref rvec i)))
        (vector-set! newvec i
                     (if (record-vector? val)
                         (record-vector-clone val)
                         val)))))
  (let ((dst (cons (car src) (record-copy (cdr src)))))
    (let loop ((defs r))
      (unless (null? defs)
        (cond ((and (keyword? (car defs)) (pair? (cdr defs)) (not (keyword? (cadr defs))))
               (record-vector-update! dst (car defs) (cadr defs))
               (loop (cddr defs)))
              (else (error "unmatched keyword in " r)))))
    dst))

(define rv-clone record-vector-clone)


;; similarity of attrs-sets test

(define (record-vector-like? rv etrv)
  (define hlp
    (lambda (props et)
      (call/cc
       (lambda (k)
         (for-each
          (lambda (e)
            (unless (assq (car e) props)
              (k #f)))
          (car et))
         #t))))
  (cond ((and (null? (car rv)) (null? (car etrv))) #t)
        ((or (null? (car rv)) (null? (car etrv))) #f)
        (else
         (or (hlp (car rv) etrv) (hlp (car etrv) rv)))))

(define rv-like? record-vector-like?)

;; end