[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
Re: Object access
Quoting Jerzy Karczmarczuk:
> The Windows distribution (sorry, but we use *that* for
> teaching...) has only tests/mzscheme directory. No mred.
> The unix source distribution neither.
Ah, right. I wonder whether there's a good reason for that...
classhack.c is enclosed. Let me emphasize the "hack" part of the name:
classhack.c includes struture definitions *copied* from MzScheme's
source.
> I have no idea whatsoever how to make snip%'s different
> from what is there: string/tab/editor/image.
>
> [...]
>
> Do you have somewhere some examples of non-orthodox snip%/
> editor constructs?
Another enclosure: graph.ss defines a snip class for plotting a
function.
Also, I put a new collection on the develop page: `guibuilder'. It's a
GUI for building MrEd GUIs. It isn't actively maintained, but I just
tired running it, and it seems to work in version 101 (not 102, due to
changes in the snip save/load interface). The guibuilder is implemented
using a pasteboard and lots of snips classes.
Matthew
#include "escheme.h"
/**************** Copied from plt/src/mzscheme/src/object.c **************/
typedef long ClassVariable;
typedef struct Scheme_Class {
Scheme_Type type;
ClassVariable *ivars; /* Order determines order of evaluation */
union {
Scheme_Closed_Prim *initf;
struct {
Scheme_Instance_Init_Proc *f;
void *data;
} insti;
} piu;
short priminit;
short pos;
struct Scheme_Class **heritage;
struct Scheme_Class *superclass; /* Redundant, but useful. */
Scheme_Object *super_init_name;
struct Scheme_Interface *equiv_intf; /* interface implied by this class */
short num_args, num_required_args, num_arg_vars;
short num_ivar, num_private, num_ref;
short num_public, num_slots; /* num_vslots == num_public */
Scheme_Object **public_names;
/* ... */
} Scheme_Class;
typedef struct Scheme_Interface {
Scheme_Type type;
short num_names, num_supers;
short for_class; /* 1 => impl iff subclass, 0 => normal interface */
Scheme_Object **names;
short *name_map; /* position in names => interface slot position */
struct Scheme_Interface **supers; /* all superinterfaces (flattened hierarchy) */
struct Scheme_Class *supclass;
short *super_offsets; /* superinterface => super's slot position offset */
Scheme_Object *defname;
} Scheme_Interface;
/*************************************************************************/
Scheme_Object *array_to_list(int c, Scheme_Object **names)
{
Scheme_Object *p = scheme_null;
while (c--)
p = scheme_make_pair(names[c], p);
return p;
}
Scheme_Object *arrays_to_list(int c1, Scheme_Object **ns1,
int c2, Scheme_Object **ns2)
/* Merge arrays. Exploit the fact that they're both
sorted. */
{
Scheme_Object **ns;
int c, i1, i2;
ns = (Scheme_Object **)scheme_malloc(sizeof(Scheme_Object*) * (c1 + c2));
c = i1 = i2 = 0;
while ((i1 < c1) || (i2 < c2)) {
if (i1 >= c1) {
ns[c++] = ns2[i2++];
} else if (i2 >= c2) {
ns[c++] = ns1[i1++];
} else {
Scheme_Object *n1 = ns1[i1];
Scheme_Object *n2 = ns2[i2];
if (n1 == n2) {
ns[c++] = n1;
i1++;
i2++;
} else if ((unsigned long)n1 < (unsigned long)n2) {
ns[c++] = ns1[i1++];
} else {
ns[c++] = ns2[i2++];
}
}
}
return array_to_list(c, ns);
}
Scheme_Object *class_to_names(int argc, Scheme_Object **argv)
{
Scheme_Class *class = (Scheme_Class *)argv[0];
if (!SCHEME_CLASSP(argv[0]))
scheme_wrong_type("class->names", "class", 0, argc, argv);
return array_to_list(class->num_public, class->public_names);
}
Scheme_Object *interface_to_names(int argc, Scheme_Object **argv)
{
Scheme_Interface *interface = (Scheme_Interface *)argv[0];
if (!SCHEME_INTERFACEP(argv[0]))
scheme_wrong_type("interface->names", "interface", 0, argc, argv);
return arrays_to_list(interface->num_names, interface->names,
interface->supclass->num_public, interface->supclass->public_names);
}
Scheme_Object *interface_to_super_interfaces(int argc, Scheme_Object **argv)
{
Scheme_Interface *interface = (Scheme_Interface *)argv[0];
if (!SCHEME_INTERFACEP(argv[0]))
scheme_wrong_type("interface->super-interfaces", "interface", 0, argc, argv);
return array_to_list(interface->num_supers, (Scheme_Object**)interface->supers);
}
Scheme_Object *scheme_initialize(Scheme_Env *env)
{
return scheme_reload(env);
}
Scheme_Object *scheme_reload(Scheme_Env *env)
{
scheme_add_global("class->names",
scheme_make_prim_w_arity(class_to_names,
"class->names",
1, 1),
env);
scheme_add_global("interface->names",
scheme_make_prim_w_arity(interface_to_names,
"interface->names",
1, 1),
env);
scheme_add_global("interface->super-interfaces",
scheme_make_prim_w_arity(interface_to_super_interfaces,
"interface->super-interfaces",
1, 1),
env);
return scheme_void;
}
4
; Demonstrates how to define new kinds of `snips' for drawing arbitary
; graphic objects in editors.
; The snip classes here are loaded by the "editor" sample program,
; which contains "Insert Plain Box" and "Insert Graph" items in its
; "Edit" menu.
; NOTE: When the result of an expression in DrScheme's interactions
; window is a snip, DrScheme copies the snip (by calling its `copy'
; method) and inserts the copy into the interactions window. So these
; classes can be partly tested directly in DrScheme's editor. Cut and
; paste won't work, though, because the snip "class" for marshaling is
; not in DrScheme's implementation domain, where the editor resides.
(require-library "string.ss") ; defines string->expr
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; A simple snip class that makes an empty square of a certain
; size. Try (make-object draw-snip% 100 100) in DrScheme to get an
; empty box (100 pixels x 100 pixles) as the result.
(define draw-snip%
(class snip% (w-in h-in)
(inherit get-admin set-snipclass set-count)
(public
[w w-in]
[h h-in])
(override
[get-extent ; called by an editor to get the snip's size
(lambda (dc x y wbox hbox descentbox spacebox lspacebox rspacebox)
(when hbox
(set-box! hbox h))
(when wbox
(set-box! wbox w))
(when descentbox
(set-box! descentbox 0))
(when spacebox
(set-box! spacebox 0))
(when rspacebox
(set-box! rspacebox 0))
(when lspacebox
(set-box! lspacebox 0)))]
[draw ; called by an editor to draw the snip
(lambda (dc x y . other)
(let* ((xw (sub1 (+ x w)))
(yh (sub1 (+ y h)))
(x (add1 x))
(y (add1 y)))
(send dc draw-line x y xw y)
(send dc draw-line xw y xw yh)
(send dc draw-line x yh xw yh)
(send dc draw-line x y x yh)))]
[copy ; clones the snip
(lambda ()
(make-object draw-snip% w h))]
[write ; marshals the snip to a text stream
(lambda (stream)
(send stream << w)
(send stream << h))]
[resize ; called by a pasetboard editor to resize the snip
(lambda (w-in h-in)
(set! w w-in)
(set! h h-in)
; send resize notification to the editor containing the snip
(let ([admin (get-admin)])
(when admin
(send admin resized this #t)))
#t)])
(sequence
(super-init)
; Need to set the "class" for unmarshaling from text stream
(set-snipclass (send (get-the-snip-class-list) find "emptydrawbox"))
(set-count 1))))
; The snip "class" is used for unmarshaling a snip from a text stream
(define draw-snip-class
(make-object
(class snip-class% ()
(inherit set-classname)
(override
[read
(lambda (stream)
(let ([w-box (box 0)]
[h-box (box 0)])
(send stream >> w-box)
(send stream >> h-box)
(make-object draw-snip% (unbox w-box) (unbox h-box))))])
(sequence
(super-init)
(set-classname "emptydrawbox")))))
; Register the snip class
(send (get-the-snip-class-list) add draw-snip-class)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; A snip class derived from draw-snip% that plots a function from 0 to
; 1. The function is specified as an S-expression to permit
; marshaling.
; Try (make-object graph-snip% '(lambda (x) (* x x))) in DrScheme.
(define graph-snip%
(class draw-snip% (function-expression)
(inherit w h set-snipclass)
(rename [super-draw draw])
(public [function (eval function-expression)]
[x-start 0]
[x-end 1]
[y-start (function x-start)]
[y-end (function x-end)]
[lmargin 5] [rmargin 5]
[tmargin 5] [bmargin 5])
(override
[draw
(lambda (dc x y . other)
(super-draw dc x y)
(let* ([bottom (- (+ h y) bmargin)]
[top (+ y tmargin)]
[right (- (+ x w) rmargin)]
[left (+ x lmargin)]
[graph-w (- w lmargin rmargin)]
[graph-h (- h tmargin bmargin)]
[x-scale (/ (- x-end x-start) graph-w)]
[dx x-scale]
[y-inv-scale (/ graph-h (- y-end y-start))]
[dy (/ y-inv-scale)]
[x-to-pos
(lambda (x)
(+ (/ (- x x-start) x-scale) left))]
[y-to-pos
(lambda (y)
(- bottom (* y-inv-scale (- y y-start))))])
(if (<= x-start 0 x-end)
(let ([x-pos (x-to-pos 0)])
(send dc draw-line x-pos bottom x-pos top)))
(if (<= y-start 0 y-end)
(let ([y-pos (- bottom (* (- y-start) y-inv-scale))])
(send dc draw-line left y-pos right y-pos)))
(let loop ((i 0))
(if (< i graph-w)
(let* ((x0 (+ x-start (* i x-scale)))
(j (y-to-pos (function x0))))
(if (and (> j y) (< j bottom))
(send dc draw-point (+ i left) j))
(loop (add1 i)))))))]
[copy
(lambda ()
(make-object graph-snip% function-expression))]
[write
(lambda (stream)
(send stream << (expr->string function-expression)))])
(sequence
(super-init 100 100)
(set-snipclass (send (get-the-snip-class-list) find "graph"))
(when (= y-start y-end)
(set! y-start (- y-start 100))
(set! y-end (+ y-end 100)))
(when (> y-start y-end)
(let ((start y-start))
(set! y-start y-end)
(set! y-end start))))))
(define graph-snip-class
(make-object
(class snip-class% ()
(inherit set-classname)
(override
[read
(lambda (stream)
(make-object graph-snip%
(read-from-string (send stream get-string))))])
(sequence
(super-init)
(set-classname "graph")))))
(send (get-the-snip-class-list) add graph-snip-class)
- Follow-Ups:
- Help on help
- From: Jerzy Karczmarczuk <karczma@info.unicaen.fr>