;;;; semantic-version.operation.scm  -*- Scheme -*-
;;;; Kon Lovett, Apr '21

;; Issues
;;
;; - Use symbol as ident impl, not string (?)
;;
;; - Support Roman Numerals & Upper/Lowercase Letters ("outline numbers").
;;
;; - Use interleaved elm chr in single sequence
;;
;; - Use vector
;;
;; - Better name for `version-depth+/-': `version-depth-extend/retract'?
;;
;; - Lot'sa overhead

(module semantic-version.operation

(;export
  ;
  version-extend
  version-extend!
  ;
  version-depth+! version-depth-!
  version-depth+ version-depth-
  ;
  version-succ! version-pred!
  version-succ version-pred)

(import scheme utf8
  (chicken base)
  (chicken type)
  (only (chicken fixnum) most-positive-fixnum fx= fx< fx<= fx-)
  (only (srfi 1) append! every make-list drop drop-right! list-copy)
  (semantic-version core)
  (semantic-version components))

;NOTE symbols are not preserved; the printname is used!
(include-relative "semantic-version.types")

(: version-extend (ver #!rest (or ver-part ver-punc) -> ver))
(: version-depth+ (ver fixnum #!optional ver-part ver-punc -> ver))
(: version-depth- (ver fixnum -> ver))
(: version-extend! (ver #!rest (or ver-part ver-punc) -> ver))
(: version-depth+! (ver fixnum #!optional ver-part ver-punc -> ver))
(: version-depth-! (ver fixnum -> ver))

(: version-succ (ver #!optional fixnum fixnum boolean -> ver))
(: version-pred (ver #!optional fixnum fixnum boolean -> ver))
(: version-succ! (ver #!optional fixnum fixnum boolean -> ver))
(: version-pred! (ver #!optional fixnum fixnum boolean -> ver))

;;

(: pair-find-nth (list fixnum #!optional (or false (* -> boolean)) -> (or false pair)))

(define (pair-find-nth ls idx #!optional pred)
  (let loop ((ls ls) (idx idx) (prev #f))
    (if (or (fx< idx 0) (null? ls)) prev
        (loop (cdr ls) (fx- idx 1) (if (or (not pred) (pred (car ls))) ls prev)) ) ) )

;;

(include-relative "semantic-version-internals")

(define-inline (check-positive-fixnum loc obj)
  (check-fixnum-range loc obj 0 most-positive-fixnum) )

;;

(define (version-extend! ver . comps)
  (let ((vern (apply version-extend (check-version 'version-extend! ver) comps)))
    (ver-parts-set! ver (ver-parts vern))
    (ver-puncs-set! ver (ver-puncs vern)) )
  ver )

(define (version-extend ver . comps)
  (list->version (append! (version->list (check-version 'version-extend ver)) comps)) )

;;

(define (version-depth+! ver cnt #!optional (part 0) (punc (default-punctuation)))
  (check-version 'version-depth+! ver)
  (ver-parts-set! ver
                  (append! (ver-parts ver)
                           (make-list (check-fixnum 'version-depth+! cnt)
                                      (check-part 'version-depth+! part))))
  ;need to include leading punct!
  (ver-puncs-set! ver
                  (append! (ver-puncs ver)
                           (make-list cnt (check-punc 'version-depth+! punc))))
  ver )

(define (version-depth-! ver cnt)
  (check-version 'version-depth-! ver)
  (cond ((zero? (check-fixnum 'version-depth-! cnt))
          ver )
        ((positive? cnt)
          (let ((puncs (ver-puncs ver)) (parts (ver-parts ver)))
            (unless (fx<= cnt (length parts))
              (error 'version-depth-! "semantic-version cannot drop such depth" ver cnt) )
            ;be direct when dropping all
            (ver-parts-set! ver (if (fx= cnt (length parts)) '() (drop-right! parts cnt)))
            ;need to drop leading punctuation
            (ver-puncs-set! ver (if (fx= cnt (length parts)) '() (drop-right! puncs cnt)))
            ver ) )
        (else
          (error 'version-depth-! "semantic-version cannot drop negative depth" ver cnt)) ) )

(define (version-depth+ ver cnt #!optional (part 0) (punc (default-punctuation)))
  (version-depth+! (copy-ver (check-version 'version-depth+ ver)) cnt part punc) )

(define (version-depth- ver cnt)
  (version-depth-! (copy-ver (check-version 'version-depth- ver)) cnt) )

;;

;FIXME should be successor/predecessor semantics, not +/-

(define (version-component-location loc ver idx #!optional pred)
  (let* ((ls (ver-parts ver))
         (len (length ls))
         (idx (if (not idx) (fx- len 1)
                  (check-fixnum-range loc idx 0 len)))
         (cel (pair-find-nth ls idx pred)) )
    (unless cel (error loc "missing adjustable version component at or before" idx))
    cel ) )

;;

;FIXME brute-force much?
(define (version-component-next? x) (->boolean (version-component-next x)))
(define (version-component-prev? x) (->boolean (version-component-prev x)))

(define (ver-succ! loc ver amt idx #!optional pred?)
  (let* ((cel (version-component-location loc ver idx pred?))
         (trg (car cel))
         (nxt (version-component-next trg (check-positive-fixnum loc amt))) )
    (unless nxt (error loc "target unavailable for operation" trg))
    (set! (car cel) nxt) )
  ver )

(define (ver-pred! loc ver amt idx #!optional pred?)
  (let* ((cel (version-component-location loc ver idx pred?))
         (trg (car cel))
         (prv (version-component-prev trg (check-positive-fixnum loc amt))) )
    (unless prv (error loc "target unavailable for operation" trg))
    (set! (car cel) prv) )
  ver )

(define (version-succ! ver #!optional (amt 1) idx search?)
  (ver-succ! 'version-succ! (check-version 'version-succ! ver)
                            amt idx (and search? version-component-next?)) )

(define (version-pred! ver #!optional (amt 1) idx search?)
  (ver-pred! 'version-pred! (check-version 'version-pred! ver)
                            amt idx (and search? version-component-prev?)) )

(define (version-succ ver #!optional (amt 1) idx search?)
  (ver-succ! 'version-succ (copy-ver (check-version 'version-succ ver))
                           amt idx (and search? version-component-next?)) )

(define (version-pred ver #!optional (amt 1) idx search?)
  (ver-pred! 'version-pred (copy-ver (check-version 'version-pred ver))
                           amt idx (and search? version-component-prev?)) )

) ;module semantic-version.operation