[plt-scheme] Editor Canvas as Output Port

--- "Williams, M. Douglas" <M.DOUGLAS.WILLIAMS at saic.com> wrote:

> The following short piece of code creates an output port to write
> text onto an editor canvas.  The attached file has a short example.
>  It works, but I'm not sure it's an adequate implementation for
> general usage.  For one thing, it only works for text, while, for
> example, DrScheme lets me write graphic elements (e.g., an image
> snip) using print (or printf even).  Am I correct in that I need to
> supply an optional-write-special-proc to handle these?  It's hard
> to tell from the documentation I've look at so far.

DrScheme's nifty printing comes in two parts. First, the ports
connected to the editor support 'write-special'. So yes, you should
implement the 'optional-write-special-proc' by inserting the special
value (which had better be a snip) into the editor.

The second part connects procedures like 'print', 'display',
'printf', etc to 'write-special'. You need to set the port's print,
display, and write handlers on the port to catch the interesting
values that you want to display graphically and 'write-special' them
to the port.

> 
> (define (make-editor-canvas-port editor-canvas)
>   (let ((text (send editor-canvas get-editor)))
>     (if text
>         (make-output-port
>          'canvas-port
>          always-evt
>          (lambda (s start end non-block? breakable?)
>            (send text insert
>                   (bytes->string/latin-1 s #f start end))
>            (- end start))
>          void)
>         #f)))
> 
> Is there a similar set of procedures that already exist somewhere I
> can use?
> 
> There seem to be similar things in the Application Framework, but
> I've only skimmed over them so far.  They seem to be overkill for
> simple MrEd applications, but that may well be a learning curve
> issue more than anything.

You can look at PLT/collects/mrlib/interactive-value-port.ss for one
example of setting the port handlers. That's not very flexible,
though.

Here's a little toy program that can print colored circles.

  (require (lib "class.ss")
           (lib "mred.ss" "mred"))
  
  (define f (new frame% (label "hi") (width 400) (height 400)))
  (define t (new text%))
  (define ec (new editor-canvas% (editor t) (parent f)))
  
  (define (make-editor-output-port text)
    (make-output-port text
                      always-evt
                      (lambda (s start end non-block? breakable?)
                        (send text insert
                              (bytes->string/latin-1 s #f start end))
                        (- end start))
                      void
                      (lambda (special buffer? breakable?)
                        (send text insert special))))
  
  (define-struct circle (radius color))
  
  (define (circle->bitmap c)
    (define diameter (* 2 (circle-radius c)))
    (define bitmap 
      (make-object bitmap% diameter diameter #f))
    (define dc (new bitmap-dc% (bitmap bitmap)))
    (define old-brush (send dc get-brush))
    (define old-pen (send dc get-pen))
    (send dc set-brush (circle-color c) 'solid)
    (send dc set-pen "black" 2 'solid)
    (send dc clear)
    (send dc draw-ellipse 0 0 diameter diameter)
    (send dc set-brush old-brush)
    (send dc set-pen old-pen)
    (send dc set-bitmap #f)
    bitmap)
  
  (define (wrap-port-handler old-handler)
    (lambda (value port)
      (if (circle? value)
          (write-special 
           (make-object image-snip% (circle->bitmap value))
           port)
          (old-handler value port))))
  
  (define out (make-editor-output-port t))
  (port-display-handler 
   out
   (wrap-port-handler (port-display-handler out)))
  (port-print-handler 
   out
   (wrap-port-handler (port-print-handler out)))
  ;(port-write-handler
  ; out
  ; (wrap-port-handler (port-write-handler out)))
  
  (send f show #t)
  (display "here's a circle:\n" out)
  (display (make-circle 10 "red") out)
  (fprintf out "\nhere's a bigger one:\n~a\n" 
           (make-circle 50 "green"))
  (display "and if you uncomment the lines above...\n" out)
  (write (make-circle 30 "purple") out)

Hope that gets you going in the right direction.
Ryan


__________________________________________________
Do You Yahoo!?
Tired of spam?  Yahoo! Mail has the best spam protection around 
http://mail.yahoo.com