console-reuse.rkt

#lang racket/base

(require racket/class
         (prefix-in gui: racket/gui)
         racket/gui/easy
         racket/gui/easy/operator
         racket/list
         racket/string)

(define max-buffer-size
  100)

(define max-text-size
  10240)

(define console%
  (class* object% (view<%>)
    (init-field @buffer)
    (super-new)

    (define/public (dependencies)
      (list @buffer))

    (define/public (create parent)
      (define editor
        (new (class gui:text%
               (super-new)
               (define allow-change? #f)
               (define/public (begin-allow-change)
                 (set! allow-change? #t))
               (define/public (end-allow-change)
                 (set! allow-change? #f))
               (define/augment (can-delete? _start _len)
                 allow-change?)
               (define/augment (can-insert? _start _len)
                 allow-change?))))
      (define buffer
        (obs-peek @buffer))
      (send editor begin-allow-change)
      (send editor insert (string-join (reverse buffer)) 0)
      (send editor end-allow-change)
      (define canvas
        (new (context-mixin gui:editor-canvas%)
             [parent parent]
             [editor editor]))
      (begin0 canvas
        (send canvas set-context 'buffer buffer)))

    (define/public (update v dep val)
      (case/dep dep
        [@buffer
         (define old
           (send v get-context 'buffer))
         (define todo
           (reverse
            (for/list ([chunk (in-list val)])
              #:break (and (not (null? old)) (eq? chunk (car old)))
              chunk)))
         (unless (null? todo)
           (define editor
             (send v get-editor))
           (send editor begin-edit-sequence)
           (send editor begin-allow-change)
           (send editor set-position (send editor last-position))
           (for ([chunk (in-list todo)])
             (send editor insert chunk))
           (define last-pos
             (send editor last-position))
           (send editor scroll-to-position last-pos #f 'same 'end)
           (when (> last-pos max-text-size)
             (send editor delete 0 (quotient max-text-size 2)))
           (send editor end-allow-change)
           (send editor end-edit-sequence)
           (send v set-context 'buffer val))]))

    (define/public (destroy v)
      (send v clear-context))))

(define (console @buffer)
  (new console%
       [@buffer @buffer]))

(module+ main
  (define/obs @buffer (list "Beginning of text."))

  (define (tick buffer)
    (define next-buffer
      (cons (format "~nThe time is now: ~a" (current-seconds)) buffer))
    (if (> (length next-buffer) max-buffer-size)
        (take next-buffer max-buffer-size)
        next-buffer))

  (thread
   (lambda ()
     (let loop ()
       (@buffer . <~ . tick)
       (sleep 1)
       (loop))))

  (define/obs @second-console? #f)
  (define console-view
    (console @buffer))

  (render
   (window
    #:size '(400 300)
    (hpanel
     console-view
     (vpanel
      (checkbox
       #:label "Show Second Console"
       #:checked? @second-console?
       (λ (_) (@second-console? . <~ . not)))
      (if-view @second-console?
               console-view
               (hpanel)))))))