macro stepper: added index-based extra navigation

svn: r12595

original commit: fc31124115aeef1049e69b7c30150e3ce4db5cd4

collects/macro-debugger/view/cursor.ss

@@ -2,6 +2,7 @@
 #lang scheme/base
 (require scheme/promise)
 (provide cursor?
+         cursor-position
          cursor:new
          cursor:add-to-end!
          cursor:remove-current!
@@ -25,107 +26,109 @@
          cursor:prefix->list
          cursor:suffix->list)
 
-(define-syntax stream-cons
+(define-struct cursor (vector count position)
-  (syntax-rules ()
+  #:mutable)
-    [(stream-cons x y)
-     (delay (cons x y))]))
 
-(define (stream-car x)
+(define (cursor:ensure-capacity c capacity)
-  (if (promise? x)
+  (define v (cursor-vector c))
-      (car (force x))
+  (when (< (vector-length v) capacity)
-      (car x)))
+    (let* ([new-capacity (ceiling (* capacity 3/2))]
-
+           [new-v (make-vector new-capacity)])
-(define (stream-cdr x)
+      (vector-copy! new-v 0 v 0)
-  (if (promise? x)
+      (set-cursor-vector! c new-v))))
-      (cdr (force x))
-      (cdr x)))
-
-(define (stream-null? x)
-  (or (null? x)
-      (and (promise? x) (null? (force x)))))
-
-(define (stream-append x y)
-  (if (stream-null? x)
-      y
-      (stream-cons (stream-car x) 
-                   (stream-append (stream-cdr x) y))))
-
-(define (stream->list s)
-  (if (stream-null? s)
-      null
-      (cons (stream-car s) (stream->list (stream-cdr s)))))
-
-;; Cursors
-
-;; A (Cursor-of 'a) is (make-cursor (list-of 'a) (Stream-of 'a))
-(define-struct cursor (prefix suffixp) #:mutable)
 
 (define (cursor:new items)
-  (make-cursor null items))
+  (define v (list->vector items))
+  (make-cursor v (vector-length v) 0))
 
 (define (cursor:add-to-end! c items)
-  (let ([suffix (cursor-suffixp c)])
+  (define count0 (cursor-count c))
-    (set-cursor-suffixp! c (stream-append suffix items))))
+  (define items-vector (list->vector items))
+  (cursor:ensure-capacity c (+ (cursor-count c) (length items)))
+  (vector-copy! (cursor-vector c) count0 items-vector)
+  (set-cursor-count! c (+ (cursor-count c) (vector-length items-vector))))
 
 (define (cursor:remove-current! c)
-  (when (cursor:has-next? c)
+  (cursor:remove-at! c (cursor-position c)))
-    (set-cursor-suffixp! c (stream-cdr (cursor-suffixp c)))))
+
+(define (cursor:remove-at! c p)
+  (define count (cursor-count c))
+  (define v (cursor-vector c))
+  (vector-copy! v p v (add1 p))
+  (vector-set! v (sub1 count) #f)
+  (set-cursor-count! c (sub1 count)))
 
 (define (cursor:next c)
-  (let ([suffix (cursor-suffixp c)])
+  (define p (cursor-position c))
-    (if (stream-null? suffix)
+  (define count (cursor-count c))
-        #f
+  (and (< p count)
-        (stream-car suffix))))
+       (vector-ref (cursor-vector c) p)))
 
 (define (cursor:prev c)
-  (let ([prefix (cursor-prefix c)])
+  (define p (cursor-position c))
-    (if (pair? prefix)
+  (define count (cursor-count c))
-        (car prefix)
+  (and (< 0 p)
-        #f)))
+       (vector-ref (cursor-vector c) (sub1 p))))
 
-(define (cursor:move-prev c)
-  (when (pair? (cursor-prefix c))
-    (let ([old-prefix (cursor-prefix c)])
-      (set-cursor-prefix! c (cdr old-prefix))
-      (set-cursor-suffixp! c (cons (car old-prefix) (cursor-suffixp c))))))
 
 (define (cursor:move-next c)
-  (when (cursor:has-next? c)
+  (define p (cursor-position c))
-    (let* ([old-suffixp (cursor-suffixp c)])
+  (define count (cursor-count c))
-      (set-cursor-prefix! c (cons (stream-car old-suffixp)
+  (when (< p count)
-                                  (cursor-prefix c)))
+    (set-cursor-position! c (add1 p))))
-      (set-cursor-suffixp! c (stream-cdr old-suffixp)))))
+
+(define (cursor:move-prev c)
+  (define p (cursor-position c))
+  (define count (cursor-count c))
+  (when (< 0 p)
+    (set-cursor-position! c (sub1 p))))
 
 (define (cursor:at-start? c)
-  (null? (cursor-prefix c)))
+  (= (cursor-position c) 0))
+
 (define (cursor:at-end? c)
-  (stream-null? (cursor-suffixp c)))
+  (= (cursor-position c) (cursor-count c)))
+
 (define (cursor:has-next? c)
   (not (cursor:at-end? c)))
+
 (define (cursor:has-prev? c)
   (not (cursor:at-start? c)))
 
 (define (cursor:move-to-start c)
-  (when (cursor:has-prev? c)
+  (set-cursor-position! c 0))
-    (cursor:move-prev c)
-    (cursor:move-to-start c)))
 
 (define (cursor:move-to-end c)
-  (when (cursor:has-next? c)
+  (set-cursor-position! c (cursor-count c)))
-    (cursor:move-next c)
-    (cursor:move-to-end c)))
 
 (define (cursor:skip-to c i)
-  (unless (or (eq? (cursor:next c) i) (cursor:at-end? c))
+  (when (<= 0 i (cursor-count c))
-    (cursor:move-next c)
+    (set-cursor-position! c i)))
-    (cursor:skip-to c i)))
 
 (define (cursor->list c)
-  (append (cursor:prefix->list c)
+  (define count (cursor-count c))
-          (cursor:suffix->list c)))
+  (define v (cursor-vector c))
+  (let loop ([i 0])
+    (if (< i count)
+        (cons (vector-ref v i)
+              (loop (add1 i)))
+        null)))
 
 (define (cursor:prefix->list c)
-  (reverse (cursor-prefix c)))
+  (define position (cursor-position c))
+  (define v (cursor-vector c))
+  (let loop ([i 0])
+    (if (< i position)
+        (cons (vector-ref v i)
+              (loop (add1 i)))
+        null)))
 
 (define (cursor:suffix->list c)
-  (stream->list (cursor-suffixp c)))
+  (define position (cursor-position c))
+  (define count (cursor-count c))
+  (define v (cursor-vector c))
+  (let loop ([i position])
+    (if (< i count)
+        (cons (vector-ref v i)
+              (loop (add1 i)))
+        null)))

collects/macro-debugger/view/stepper.ss

@@ -49,6 +49,9 @@
     (define (focused-term)
       (cursor:next terms))
 
+    ;; current-step-index : notify of number/#f
+    (field/notify current-step-index (new notify-box% (value #f)))
+
     ;; add-deriv : Deriv -> void
     (define/public (add-deriv d)
       (let ([trec (new term-record% (stepper this) (raw-deriv d))])
@@ -173,6 +176,28 @@
       (new button% (label "Next term") (parent navigator)
            (callback (lambda (b e) (navigate-down)))))
 
+    (define nav:text
+      (new text-field%
+           (label "Step#")
+           (init-value "00000")
+           (parent extra-navigator)
+           (stretchable-width #f)
+           (stretchable-height #f)
+           (callback
+            (lambda (b e)
+              (when (eq? (send e get-event-type) 'text-field-enter)
+                (let* ([value (send b get-value)]
+                       [step (string->number value)])
+                  (cond [(exact-positive-integer? step)
+                         (navigate-to (sub1 step))]
+                        [(equal? value "end")
+                         (navigate-to-end)])))))))
+    (send nav:text set-value "")
+    (listen-current-step-index
+     (lambda (n)
+       (send nav:text set-value
+             (if (number? n) (number->string (add1 n)) ""))))
+
     (define/private (trim-navigator)
       (if (> (length (cursor->list terms)) 1)
           (send navigator change-children
@@ -223,6 +248,9 @@
     (define/public-final (navigate-next)
       (send (focused-term) navigate-next)
       (update/save-position))
+    (define/public-final (navigate-to n)
+      (send (focused-term) navigate-to n)
+      (update/save-position))
 
     (define/public-final (navigate-up)
       (when (focused-term)
@@ -253,7 +281,7 @@
             #f
             (send text line-start-position (unbox end-box))
             'start))
-    
+
     ;; update/preserve-view : -> void
     (define/public (update/preserve-view)
       (define text (send sbview get-text))
@@ -271,7 +299,7 @@
       (define multiple-terms? (> (length (cursor->list terms)) 1))
       (send text begin-edit-sequence)
       (send sbview erase-all)
-      
+
       (update:show-prefix)
       (when multiple-terms? (send sbview add-separator))
       (set! position-of-interest (send text last-position))
@@ -284,6 +312,7 @@
             #f
             (send text last-position)
             'start)
+      (update-nav-index)
       (enable/disable-buttons))
 
     ;; update:show-prefix : -> void
@@ -305,6 +334,12 @@
                       (send trec display-initial-term))
                     (cdr suffix0)))))
 
+    ;; update-nav-index : -> void
+    (define/private (update-nav-index)
+      (define term (focused-term))
+      (set-current-step-index
+       (and term (send term get-step-index))))
+
     ;; enable/disable-buttons : -> void
     (define/private (enable/disable-buttons)
       (define term (focused-term))
@@ -312,6 +347,7 @@
       (send nav:previous enable (and term (send term has-prev?)))
       (send nav:next enable (and term (send term has-next?)))
       (send nav:end enable (and term (send term has-next?)))
+      (send nav:text enable (and term #t))
       (send nav:up enable (cursor:has-prev? terms))
       (send nav:down enable (cursor:has-next? terms)))
 

collects/macro-debugger/view/term-record.ss

@@ -204,6 +204,9 @@
     (define/public-final (has-next?)
       (and (get-steps) (not (cursor:at-end? (get-steps)))))
 
+    (define/public-final (get-step-index)
+      (and (get-steps) (cursor-position (get-steps))))
+
     (define/public-final (navigate-to-start)
       (cursor:move-to-start (get-steps))
       (save-position))
@@ -216,6 +219,9 @@
     (define/public-final (navigate-next)
       (cursor:move-next (get-steps))
       (save-position))
+    (define/public-final (navigate-to n)
+      (cursor:skip-to (get-steps) n)
+      (save-position))
 
     ;; save-position : -> void
     (define/private (save-position)