path: root/par/piece-table.scm

;; Utils
(define (character-newline? ch)
  (char=? ch #\newline))



;; Pieces themselves: the buffer is a reference to the buffer they take their
;; data from.
;; Start and end are numbers.
;; The type defines how they should be rendered, it makes
;; possible to account for hyperlinks or stuff like that in the future with
;; ease.
;; Linebreaks is a vector of linebreaks (easy to count length)
(define-record-type <piece>
  (%make-piece buffer start length type linebreaks next prev)
  piece?
  (buffer piece-buffer set-piece-buffer!)
  (start piece-start set-piece-start!)
  (length piece-length set-piece-length!)
  (type piece-type set-piece-type!)
  (linebreaks piece-linebreaks set-piece-linebreaks!)
  (next %piece-next %set-piece-next!)
  (prev %piece-prev %set-piece-prev!))

(define-record-type <sentinel-piece>
  (make-sentinel-piece next prev)
  sentinel-piece?
  (next %sentinel-piece-next %set-sentinel-piece-next!)
  (prev %sentinel-piece-prev %set-sentinel-piece-prev!))

;; TODO think about a way to make all this polymorphism automagic
(define (piece-next p)
  (cond
    ((sentinel-piece? p) (%sentinel-piece-next p))
    ((piece? p) (%piece-next p))))

(define (piece-prev p)
  (cond
    ((sentinel-piece? p) (%sentinel-piece-prev p))
    ((piece? p) (%piece-prev p))))

(define (set-piece-prev! p prev)
  (cond
    ((sentinel-piece? p) (%set-sentinel-piece-prev! p prev))
    ((piece? p) (%set-piece-prev! p prev))))

(define (set-piece-next! p next)
  (cond
    ((sentinel-piece? p) (%set-sentinel-piece-next! p next))
    ((piece? p) (%set-piece-next! p next))))
;;


(define (index-linebreaks buffer start length)
  (define str (buffer->string buffer))
  (define (string-foreach* str f from length)
    (let loop ((i 0))
      (unless (= i length)
        (f i (string-ref str (+ start i)))
        (loop (+ i 1)))))
  (define outlist (list))

  (string-foreach* (buffer->string buffer)
                   (lambda (i ch)
                     (when (character-newline? ch)
                       (set! outlist (cons i outlist))))
                   start length)
  (list->vector (reverse outlist)))

(define (can-merge-pieces? a b)
  ;; Maybe simplify the and/or/not magic?
  (and (not (or (sentinel-piece? a) (sentinel-piece? b)))
       (or
         (or (= 0 (piece-length a)) (= 0 (piece-length b)))
         (and (eq? (piece-buffer a) (piece-buffer b))
              (= (+ (piece-start a) (piece-length a)) (piece-start b))
              (equal? (piece-type a) (piece-type b))))))

(define (merge-pieces! a b)
  (when (= 0 (piece-length a)) ;; First is empty, so we eat it
    (set-piece-start! a (piece-start b)))
  (set-piece-length! a (+ (piece-length a) (piece-length b)))
  (set-piece-linebreaks! a (vector-append (piece-linebreaks a)
                                          (piece-linebreaks b)))
  (set-piece-next! a (piece-next b))
  (unless (sentinel-piece? (piece-next b)) (set-piece-prev! (piece-next b) a)))

(define (split-linebreaks linebreaks at)
  (let* ((lb-l   (vector-length linebreaks))
         (lb-at  (let loop ((i 0))
                   (if (and (< i lb-l) (< at (vector-ref linebreaks i)))
                     (loop (+ i 1))
                     i))))
    (values
      (vector-copy linebreaks 0 lb-at)
      (vector-map (lambda (x) (- x at))
                  (vector-copy linebreaks lb-at lb-l)))))

;; Piece API
(define (make-piece buffer start length type prev next)
  (%make-piece buffer start length type (index-linebreaks buffer start length)
               prev next))

(define (connect-pieces! a b)
  (begin
    (set-piece-next! a b)
    (set-piece-prev! b a)))

(define (split-piece! a at)
  (if (and (= at 0) (sentinel-piece? a))
    (values a a) ;; Just return the sentinel twice, as this is only used to
                 ;; take one of them
    (let-values (((lb-a lb-b) (split-linebreaks (piece-linebreaks a) at)))
      (letrec* ((b (%make-piece (piece-buffer a)
                                (+ at (piece-start a))
                                (- (piece-length a) at)
                                (piece-type a)
                                lb-b
                                (piece-next a)
                                a)))
        (unless (sentinel-piece? (piece-next a))
          (set-piece-prev! (piece-next a) b))
        (set-piece-length! a at)
        (set-piece-linebreaks! a lb-a)
        (set-piece-next! a b)
        (values a b)))))



;; INTERNAL BUFFERS: The indirection level of the buffer records is cool, so we
;; can resize the underlying strings and keep all the pieces untouched and
;; pointing to the correct thing.

;; There's nothing preventing the programmer from writing in the ro-buffer...
;; but it will be hidden under the piece-table interface so nothing should
;; happen
(define-record-type <ro-buffer>
  (make-ro-buffer string)
  ro-buffer?
  (string ro-buffer-string))

;; This is where things are added, it's able to grow to handle new additions
(define-record-type <add-buffer>
  (%make-add-buffer string used)
  add-buffer?
  (string add-buffer-string set-add-buffer-string!)
  (used add-buffer-used set-add-buffer-used!))

;; TODO think about a way to make all this polymorphism automagic
(define (buffer->string buffer)
  "Returns the underlying string of the buffer"
  (cond
    ((add-buffer? buffer) (add-buffer-string buffer))
    ((ro-buffer? buffer)  (ro-buffer-string buffer))))
;;

(define add-buffer-length (make-parameter 100))

(define (make-add-buffer)
  (%make-add-buffer (make-string (add-buffer-length)) 0))

(define (enlarge-add-buffer! add-buffer at-least)
  (let* ((str (add-buffer-string add-buffer))
         (len (string-length str))
         ; TODO: Better algo here?
         (new (make-string (+ len at-least (add-buffer-length)))))
    (set-add-buffer-string! add-buffer new)
    (string-copy! new 0 str)))

(define (add-buffer-append! add-buffer str)
  "Appends to add buffer, growing if necessary"
  (let ((append-len  (string-length str))
        (buffer-used (add-buffer-used add-buffer))
        (buffer-size (string-length (add-buffer-string add-buffer))))
    (when (>= (+ append-len buffer-used) buffer-size)
      (enlarge-add-buffer! add-buffer append-len))
    (string-copy! (add-buffer-string add-buffer) buffer-used str)
    (set-add-buffer-used! add-buffer (+ append-len buffer-used))))



;; The piece table itself;
;; original is a ro-buffer, add is an add-buffer (a string designed to grow)
;; and pieces is a piece that has its prev and next.
(define-record-type <piece-table>
  (%make-piece-table original-buffer add-buffer piece)
  piece-table?
  (original-buffer piece-table-original-buffer set-piece-table-original-buffer!)
  (add-buffer piece-table-add-buffer set-piece-table-add-buffer!)
  (piece piece-table-piece set-piece-table-piece!))


(define (make-piece-table original)
  (letrec* ((ro-buffer (make-ro-buffer original))
            (piece     (make-piece ro-buffer 0 (string-length original) 'normal
                                   sentinel sentinel))
            (sentinel  (make-sentinel-piece piece piece)))
    (set-piece-prev! piece sentinel)
    (set-piece-next! piece sentinel)
    (%make-piece-table
      ro-buffer (make-add-buffer) piece)))

(define (piece-table-index->piece+index piece-table pos)
  "Returns (values piece remainder) or eof-object"
  (let loop ((piece (piece-table-piece piece-table))
             (rem pos))
    (cond
      ((sentinel-piece? piece)
       (if (= rem 0)
         (values piece rem)
         (error "Requested position out of piece-table")))
      ((< rem (piece-length piece))
       (values piece rem))
      (else
       (loop (piece-next piece) (- rem (piece-length piece)))))))

(define (piece-table-last-piece piece-table)
  (piece-prev (piece-prev (piece-table-piece piece-table))))




;; API

(define (piece-table-index piece-table pos)
  ;; TODO: Validate input
  (let-values (((piece idx) (piece-table-index->piece+index piece-table pos)))
   (string-ref (buffer->string (piece-buffer piece))
               (+ (piece-start piece) idx))))

(define (piece-table-text-length piece-table)
  (let loop ((piece (piece-table-piece piece-table))
             (acc   0))
    (if (sentinel-piece? (piece-next piece))
      (+ acc (piece-length piece))
      (loop (piece-next piece) (+ (piece-length piece) acc)))))

(define (%piece-fold-from piece f identity)
  (let loop ((piece piece)
             (acc   identity))
    (unless (sentinel-piece? piece)
      (loop (piece-next piece) (f piece acc)))))

(define (%piece-fold-from-right piece f identity)
  (let loop ((piece piece)
             (acc  identity))
    (unless (sentinel-piece? piece)
      (loop (piece-prev piece) (f piece acc)))))


(define (piece-table-for-each piece-table f from to)
  ;; TODO: default from and to
  ;; TODO: maybe combine with the `piece-table-index->piece+index` to find the
  ;; `from`
  ;; TODO: make this lower level, searching from a piece, not from the table
  ;; TODO: implement using `%piece-fold-from`
  "Calls `f` through the characters of the piece-table, like `string-for-each`
  would do, but the `f` call also includes the piece (to expose extra data) and
  the index of the character"
  (let loop ((idx   0)
             (start 0)
             (piece (piece-table-piece piece-table)))
    (let* ((len   (piece-length piece))
           (end   (+ start len))
           (more? (not (sentinel-piece? (piece-next piece)))))
      (when (< idx to) ;; Skip tail
        (if (or (= idx end) (<= end from))
          ;; Current piece doesn't contain the section we need or finished
          ;; Jump to next piece
          (when more? (loop end end (piece-next piece)))
          ;; Current piece contains part of the section we need, go char by
          ;; char
          (begin
            (when (<= from idx)
              (f
                (string-ref (buffer->string (piece-buffer piece))
                            (+ (piece-start piece) (- idx start)))
                idx
                piece))
            ;; There are chars to process in this piece
            (loop (+ idx 1) start piece)))))))

(define (piece-table-for-each-right piece-table f from to)
  "-right version of piece-table-for-each, it finds the tail and goes
  backwards"
  ;; TODO: not implemented yet
  ;; TODO: make this lower level, searching from a piece, not from the table
  )


(define (piece-table-insert! piece-table pos str type)
  ;; TODO: validate input
  ;; TODO: Try to reuse the caracters on the target buffer if they are already
  ;; there? Is this maximum evilness? => it's just a string-ref and it prevents
  ;; us from creating pieces!

  (let* ((add-buffer (piece-table-add-buffer piece-table))
         (start      (add-buffer-used add-buffer))
         (_          (add-buffer-append! add-buffer str))
         (candidate  (make-piece add-buffer
                                start
                                (string-length str)
                                type
                                #f #f)))
    (unless (= 0 (string-length str))
      (let*-values (((piece idx)
                     (piece-table-index->piece+index piece-table pos)))
        (cond
          ((= idx 0)
           (connect-pieces! (piece-prev piece) candidate)
           (connect-pieces! candidate piece)
           (when (can-merge-pieces? (piece-prev piece) candidate)
             (merge-pieces! (piece-prev piece) candidate)))
          (else
            (let-values (((first second) (split-piece! piece idx)))
              (connect-pieces! first candidate)
              (connect-pieces! candidate second)
              (when (can-merge-pieces? first candidate)
                (merge-pieces! first candidate)))))))))


(define (piece-table-delete! piece-table from len)
  (unless (= 0 len)
    (let*-values (((start-piece idx) (piece-table-index->piece+index
                                       piece-table from))
                  ((first second) (split-piece! start-piece idx))
                  ((end-piece end-idx) (piece-table-index->piece+index
                                         piece-table (+ from len)))
                  ((third fourth) (split-piece! end-piece end-idx)))
      (connect-pieces! first fourth))))

;; Finding:
;; NOTE: Line breaks are optimized.

(define (piece-table-find-line-break piece-table idx)
  (let loop ((idx 0)
             (piece (piece-table-piece piece-table))
             (rem idx))
     (let* ((len     (piece-length piece))
            (lines   (piece-linebreaks piece))
            (lc      (vector-length lines)))
        (cond
          ((< rem lc)
           (+ idx (vector-ref lines rem)))
          ;; TODO: No more pieces, return the end or eof?
          ((sentinel-piece? (piece-next piece))
           (eof-object))
          (else
           (loop (+ idx len) (piece-next piece) (- rem lc)))))))

(define (piece-table-find piece-table char from)
  ;; TODO: generalize the from
  ;; TODO: Implement the backwards one too
  (call/cc (lambda (cont)
             (piece-table-for-each
               piece-table
               (lambda (c i p)
                 (when (char=? c char)
                   (cont i)))
               from
               (piece-table-text-length piece-table))
             (cont (eof-object)))))



;; Serialization - Deserialization
(define (piece-table-write port)
  "Write a piece table to port"
  #f)
(define (piece-table-read port)
  "Read a piece table stored in port"
  #f)



;; From/to string
(define string->piece-table make-piece-table)

(define (piece-table-substring piece-table from to)
  (let ((out-string (make-string (- to from))))
    (let loop ((piece (piece-table-piece piece-table))
               (acc   0))
      (if (or (sentinel-piece? piece) (>= acc to))
        out-string
        (begin
          (when (>= (+ (piece-length piece) acc) from)
            (string-copy!
              out-string
              (max (- acc from) 0)
              (buffer->string (piece-buffer piece))
              (+ (piece-start piece) (max (- from acc) 0))
              (+ (piece-start piece) (min (- to acc) (piece-length piece)))))
          (loop (piece-next piece) (+ acc (piece-length piece))))))))

(define (piece-table->string piece-table)
  (piece-table-substring piece-table 0 (piece-table-text-length piece-table)))

;; Interact with lines: interesting for the UI
(define (piece-table-line piece-table line-number)
  (let ((start (if (= line-number 0) 0
                 (+ 1 (piece-table-find-line-break piece-table
                                                   (- line-number 1)))))
        (end   (piece-table-find-line-break piece-table line-number)))
    (cond
      ((eof-object? start)   start)
      ((eof-object? end)     (piece-table-substring
                               piece-table start
                               (piece-table-text-length piece-table)))
      (else (piece-table-substring piece-table start end)))))