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 (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 (make-piece buffer start length type prev next)
  (%make-piece buffer start length type (index-linebreaks buffer start length)
               prev next))

(define (can-merge-pieces? a b)
  ;; Maybe simplify the and/or/not magic?
  (and (not (or (null? a) (null? 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 (null? (piece-next b)) (set-piece-prev! (piece-next b) a)))

(define (connect-pieces! a b)
  (if (can-merge-pieces? a b)
    (merge-pieces! a b)
    (begin
      (set-piece-next! a b)
      (set-piece-prev! 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)))))

(define (split-piece! a at)
  (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 (null? (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!))

(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 and returns the resulting piece
  as a template function"
  (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))

    ;; TODO: make this another way? maybe it's fine to do it like this...
    (lambda (type)
      (make-piece add-buffer
                  buffer-used
                  (string-length str)
                  type
                  (list)
                  (list)))))



;; 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)
  (let ((ro-buffer (make-ro-buffer original)))
    (%make-piece-table
      ro-buffer (make-add-buffer)
      (make-piece ro-buffer 0 (string-length original) 'normal (list) (list)))))

(define (piece-table-index piece-table pos)
  ;; TODO: Validate input
  (let loop ((p (piece-table-piece piece-table))
             (start 0))
    (let* ((end   (piece-length p)))
      (if (<= start pos (+ start end -1))
        (string-ref (buffer->string (piece-buffer p)) (- pos start))
        (if (not (null? (piece-next p)))
          (loop (piece-next p) (+ start end))
          (eof-object))))))

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

(define (piece-table-for-each piece-table f from to)
  ;; TODO: default from and to
  "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 (null? (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-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?
          ((null? (piece-next piece))
           (eof-object))
          (else
           (loop (+ idx len) (piece-next piece) (- rem lc)))))))

(define (piece-table-index->piece+index piece-table pos)
  "Returns (values piece remainder) or eof-object"
  (let loop ((idx 0)
             (piece (piece-table-piece piece-table))
             (rem pos))
     (let ((len (piece-length piece)))
       (cond
         ((<= rem len)
          (values piece rem))
         ((null? (piece-next piece))
          ;; TODO: No more pieces, return the end or eof?
          (error "Requested position out of piece-table"))
         (else
          (loop (+ idx 1) (piece-next piece) (- rem len)))))))

(define (piece-table-piece-index piece-table i)
  (let ((piece-prev/next (if (< i 0) piece-prev piece-next))
        (inc/dec         (if (< i 0) - +)))
    (let loop ((piece (piece-table-piece piece-table))
               (idx   0))
      (if (= idx i)
        piece
        (loop (piece-prev/next piece) (inc/dec idx 1))))))

(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!

  ;; TODO Maybe remove this?
  (define candidate ((add-buffer-append!
                       (piece-table-add-buffer piece-table) str)
                     type))

  (unless (= 0 (string-length str))
    (let*-values (((piece idx) (piece-table-index->piece+index piece-table pos)))
      (if (and (= idx (piece-length piece))
               (can-merge-pieces? piece candidate))
        (merge-pieces! piece candidate)
        (let-values (((first second) (split-piece! piece idx)))
          (connect-pieces! first candidate)
          (connect-pieces! candidate second))))))


; TODO: SET-CDR for the win?
; - That would need other way to find the affected pieces and manipulate them.
; > we'll leave it for the future
(define (piece-table-delete! piece-table from len)
  ;; TODO: Validate input
  (unless (= 0 len)
    (let*-values (((start-piece idx) (piece-table-index->piece+index
                                       piece-table from))
                  ((first second) (split-piece! start-piece idx))
                  ;; We can search from the `second` here, because it's going
                  ;; to be at least in second, and we only iterate once that
                  ;; way
                  ((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))))



;; 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 (null? piece) (>= acc to))
        out-string
        (begin
          (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)))))