Matthew (cc'ing plt-dev)-
On Mar 3, 2009, at 4:00 PM, Matthew Flatt wrote:
I think you want to implement the `prop:print-convert-constructor-
name'
property:
#lang scheme
(provide external)
(require mzlib/pconvert-prop)
(define-struct internal (value) #:transparent
#:property prop:print-convert-constructor-name 'external)
(define (external v) (make-internal v))
I looked into that option, but it is not sufficiently general for my
goal.
I think reducing my issue down to a simpler test case for presentation
to the list was a mistake; I've corrected that mistake at the end of
this email.
----
I do not want to expose the internal structure at all; I want an
abstract view of the fields it contains. In general, the designer of
an abstract data type wants to only provide an abstract view of that
type. Sometimes that goal conflicts with constructor-style printing,
but not always.
In my particular case, I am trying to develop a multiset abstraction,
``bag''.
The primary constructor for bag (or ``pseudo-constructor'' if you
prefer) is a *procedure* and not one of the constructors resulting
from a define-struct special form. The pseudo-constructor for bag has
an interface analogous to that of the list procedure.
Internally a bag is represented by a structure, unordered, with one
field (which itself holds a list). But I do not want my external
student clients to see that view; I want them only to see an
expression involving the bag pseudo-constructor, and the exported
operations on the bag abstraction.
----
So, back to my question: "if I am developing a teachpack that is
intended for use with the Student languages (Beginning Student et al),
how do I override how structures I define are printed?"
I have attached the code I have below so you can see concretely what I
am talking about. The end goal here is that I want the following to
work as follows at the Interactions Window:
> (bag 1 2)
(bag 1 2)
but I cannot figure out how to get that effect in the Student
languages. (I *can* get it via the mzlib/pconvert library alone.) At
this point I have employed the prop:print-convert-constructor-name
property to implement the following approximation:
> (bag 1 2)
(make-bag (list 1 2))
but this does not satisfy me.
-Felix
Here is the relevant code:
;;; FILE: bag.ss
#lang scheme
(provide bag bag? bag-contains?
bag-choose bag-choose-first bag-choose-rest
bag-length bag-union bag-map bag-fold
subbag?)
(require mzlib/pconvert)
(require mzlib/pconvert-prop)
#|
(install-converting-printer)
|#
;; A [Bagof X] is a (make-unordered [Listof X])
;; interpretation:
;; a (make-unordered (list x1 x2 .. xN) is a multiset containing N
elements
(define-struct unordered (elems)
#:property prop:equal+hash
(let ((hasher (lambda (b hash)
(foldr (lambda (x n) (bitwise-ior (hash x) n)) 0))))
(list (lambda (b1 b2 equal?)
(and (= (bag-length b1) (bag-length b2))
(subbag? b1 b2)
(subbag? b2 b1)))
hasher
hasher))
#:property prop:custom-write
(lambda (b p write-mode)
(let ((p* (open-output-string)))
(if write-mode
(write (unordered-elems b) p*)
(display (unordered-elems b) p*))
(write-string "#<bag " p)
(write-string (get-output-string p*)
p)
(write-string ">" p)))
#:property prop:print-convert-constructor-name 'make-bag
#:transparent
)
(current-print-convert-hook
(let ((old-hook (current-print-convert-hook)))
(lambda (v basic-convert sub-convert)
(if (bag? v)
`(bag ,@(map sub-convert (unordered-elems v)))
(old-hook v basic-convert sub-convert)))))
(define (bag? x)
(unordered? x))
;; subbag? : [Bagof X] [Bagof X] -> Boolean
(define (subbag? b1 b2)
(andmap (lambda (x) (bag-contains? b2 x))
(unordered-elems b1)))
;; bag-contains? : [Bagof X] X -> Boolean
(define (bag-contains? b x)
(not (not (member x (unordered-elems b)))))
;; bag : X ... -> [Bagof X]
(define (bag . l)
(make-unordered l))
;; bag-choose : [Bagof X] -> (values X [Bagof X])
(define (bag-choose b)
(values (car (unordered-elems b))
(make-unordered (cdr (unordered-elems b)))))
;; bag-choose-first : [Bagof X] -> X
(define (bag-choose-first b)
(call-with-values (lambda () (bag-choose b)) (lambda (x b*) x)))
;; bag-choose-rest : [Bagof X] -> [Bagof X]
(define (bag-choose-rest b)
(call-with-values (lambda () (bag-choose b)) (lambda (x b*) b*)))
;; bag-length : [Bagof X] -> Nat
(define (bag-length b)
(length (unordered-elems b)))
;; bag-union : [Bagof X] ... -> [Bagof X]
(define (bag-union . l)
(make-unordered (append-map unordered-elems l)))
;; bag-map : (X -> Y) [Bagof X] -> [Bagof Y]
(define (bag-map f b)
(make-unordered (map f (unordered-elems b))))
;; bag-append-map : (X -> [Bagof Y]) [Bagof X] -> [Bagof Y]
(define (bag-append-map f b)
(foldr bag-union (bag) (map f (unordered-elems b))))
;; bag-fold : (X Y -> Y) Y [Bagof X] -> Y
(define (bag-fold f z b)
(foldr f z (unordered-elems b)))
;; build-bag : Nat (Nat -> X) -> [Bagof X]
(define (build-bag n f)
(make-unordered (build-list n f)))
;;; END OF FILE bag.ss
;; The first three lines of this file were inserted by DrScheme. They
record metadata
;; about the language level of this file in a form that our tools can
easily process.
#reader(lib "htdp-intermediate-lambda-reader.ss" "lang")((modname
arrangements) (read-case-sensitive #t) (teachpacks ((lib "world.ss"
"teachpack" "htdp"))) (htdp-settings #(#t constructor repeating-
decimal #f #t none #f ((lib "world.ss" "teachpack" "htdp")))))
;;; FILE: arrangements.ss
(require "bag.ss")
;; A Word is a [Listof Symbol]
;; all-placements : Symbol Word -> [Bagof Word]
(check-expect (all-placements 's '()) (bag '(s)))
(check-expect (all-placements 's '(a)) (bag '(s a) '(a s)))
(check-expect (all-placements 's '(a b)) (bag '(s a b) '(a s b) '(a b
s)))
(define (all-placements s w)
(cond
((empty? w) (bag (list s)))
(else (bag-union
(bag (cons s w))
(bag-map (lambda (w*) (cons (first w) w*))
(all-placements s (rest w)))))))
;; arrangements : Word -> [Bagof Word]
;; produces all permutations of a-word
(check-expect (arrangements empty) (bag empty))
(check-expect (arrangements (list 'd)) (bag (list 'd)))
(check-expect (arrangements (list 'c 'd)) (bag (list 'c 'd) (list 'd
'c)))
(check-expect (arrangements (list 'c 'd)) (bag (list 'd 'c) (list 'c
'd)))
(define (arrangements x)
(cond
((empty? x) (bag empty))
(else (bag-fold (lambda (w* b)
(bag-union (all-placements (first x) w*)
b))
(bag)
(arrangements (rest x))))))
;;; END OF FILE arrangements.ss
_________________________________________________
For list-related administrative tasks:
http://list.cs.brown.edu/mailman/listinfo/plt-dev
