s c h e m a t i c s : c o o k b o o k

#lang scheme/gui
(define my-string-snip%
  (class snip%
    (inherit set-snipclass get-style get-admin)
    (init-field
     
     (my-string "aaa  aaa"))
    
    (define/override get-extent
      (lambda (dc x y w h descent space lspace rspace)
        ;(for-each (lambda (b) (when (box? b) (set-box! b 0)))
        ;           (list descent space lspace rspace))
        
        (let-values (((width height b s) (send dc get-text-extent (format "~A" my-string) (send (get-style) get-font))))
          (when (box? w) (set-box! w width))
          (when (box? h) (set-box! h height)))))
    
    (define/override (draw dc x y left top right bottom dx dy draw-caret?)
      (let ([orig-pen (send dc get-pen)]
            [orig-brush (send dc get-brush)]
            [snip-w (- right left)]
            [snip-h (- bottom top)])
        (send dc set-pen body-pen)
        (send dc set-brush body-brush)
        (send dc draw-text (format "~A" my-string) x y)
        (let-values (((width height b s) (send dc get-text-extent (format "~A" my-string))))
          (send dc draw-line x y (+ x width) y))
        (send dc set-pen orig-pen)
        (send dc set-brush orig-brush))
      )
    (super-instantiate ())
    (set-snipclass my-string-snipclass%)
    ))

(define my-string-snipclass%
  (make-object
      (class snip-class% 
        (define/override (read s)
          (make-object my-string-snip%))
        (super-instantiate ())
        )))

;;;;;;;;;;;;;;;;

(define body-pen (send the-pen-list find-or-create-pen "blue" 0 'solid))
(define body-brush (send the-brush-list find-or-create-brush "WHITE" 'solid))

(define f (instantiate frame% ("example" #f 500 300) ))

(define c (new editor-canvas% [parent f]))

(define p (new pasteboard%))

(send c set-editor p)

(send f show #t)

;(sleep 5)


(send p insert (new my-string-snip% (my-string "ca")) 10 80)
(send p insert (new my-string-snip% (my-string "c   a")) 10 100)
(send p insert (new my-string-snip% (my-string "c      a")) 10 120)
(send p insert (new my-string-snip% (my-string "c         a")) 10 140)
(send p insert (new my-string-snip% (my-string "c            a")) 10 160)