[standard-fish] small house facade, with attribute handling code

[Hendrik Boom]

door.rkt draws a picture of a small house, with a door and windows.
Different picture each time you run it.

The bulk of the code is there to handle attributes (like colours and
sizes) in an association list, so that you can establish defaults and
the like.

One thing I know is that the attribute-handling code isn't right yet,
and follows different conventions in different parts of it.

Sometimes I have multipls versions of a function that are identical
except for using different argument conventions.

It's still very much in a state of flux.

Suggestions very welcome.

-- hendrik

[Hendrik Boom]

Today's version, together with a new README.md file describing my
longer-term intentions, rather than what the program dies right now.

The code resides on a monotone repository on my server, which I hope to
figure out how to make publically accessible.

I haven't written a formal copyrght notice; but I am hereby delaring
it's free software, and will probably be released under the GPL or MIT
licence. Advice welcome.

Though I suspect no one much will develop anything using it, but maybe
use it as an insperation for something completely different.

-- hendrik

> --
> You received this message because you are subscribed to the Google Groups "Racket Users" group.
> To unsubscribe from this group and stop receiving emails from it, send an email to racket-users...@googlegroups.com.
> To view this discussion on the web visit https://groups.google.com/d/msgid/racket-users/20190824122733.ov2gfaerxsgl5ajz%40topoi.pooq.com.

> #lang racket
> (require pict)
> (require racket/gui/base)
> (require racket/random)
>
> (define (show tag thing) (print (cons tag thing)) thing)
>
> ; (list 'random (random 1 10) (random 1 2) (random 1 234))
> ; (list 'chosen (random-ref '(a b c d e f)))
> ; (list 'nope)
> ; (show 'showtest 'showdatum)
>
>
> ; Attribute management
>
>
> ; ali is an environment. It should contain all the parameters that are neede to make a typical whatever (at the moment, the whatever is a door.)
> ; At the moment, also, it allows attributes to be defined as functions; at lookup time the entire association list is passed to the function so that its value can depend on other (not necessarily previous) parameters.
>
> ; This mechanism was originally introduced for flexibility, but is being used mainly to implement the freeze operation.
>
> (define (looker name ali succeed fail)
> (letrec (
> (lookup2 (lambda (name aa succeed fail)
> (if (eq? aa '())
> (fail)
> (if (eq? name (caar aa))
> (let ((value (cdar aa)))
> (if (procedure? value)
> (succeed (value ali))
> (succeed value)
> )
> )
> (lookup2 name (cdr aa) succeed fail)
> )
> )
> )))
> (lookup2 name ali succeed fail)
> )
> )
>
> (define (lookup name ali fail)
> (looker name ali (lambda (result) result) fail)
> )
> (define (old lookup name ali fail)
> (letrec (
> (lookup2 (lambda (name aa fail)
> (if (eq? aa '())
> (fail)
> (if (eq? name (caar aa))
> (let ((value (cdar aa)))
> (if (procedure? value)
> (value ali)
> value
> )
> )
> (lookup2 name (cdr aa) fail)
> )
> )
> )))
> (lookup2 name ali fail)
> )
> )
>
> (define (binda name value a) (cons (cons name value) a))
>
> (define (bind name value object)
> (lambda (a)
> (object (binda name value a))
> )
> )
>
> ; Freezing is a mechanism for choosing parameters to be passed down to more local objects, so, for example, we can set a style for all he windows in a house, but allow each house to have its own style for windoess. This is accomplished by having the window-style be a function instead of a value. The freeze calls the function and rebids the name to the result of that function. The resulting associon list is passed down to lower objects.
>
> (define (freezea name a)
> (let ((value (lookup name a (lambda () '()))))
> (if (eq? value '()) a (binda name value a))))
>
> ; Got the wrong definition for lookup. Need a way after the lookup to base decision on its success. Returning '() in't enough. I wonder what the right definition is.
>
> (define (freeze name f a)
> ( let (( value (lookup name a (lambda () '())) ))
> (if (eq? value '())
> f
> (lambda (a) (f (binda name value a)))
> )
> )
> )
>
> (define (freezeo name object)
> ( lambda (a)
> (let (( value (lookup name a (lambda () '())) ))
> (if (eq? value '())
> (object a)
> (object (binda name value a))
> )
> ))
> )
>
> (define (with a name value) (cons (cons name value) a))
>
>
> ; Graphics combinators
>
> (define ( hor l )
> (if (cons? l)
> (if
> (null? (cdr l))
> (car l)
> (let
> ( [rest (hor (cdr l))] )
> (lambda (a) (hc-append ((car l) a) (rest a)))
> )
> )
> (print "ERROR: null list in hor")
> )
> )
>
> (define ( vert l )
> (if (cons? l)
> (if
> (null? (cdr l))
> (car l)
> (let
> ( [rest (vert (cdr l))] )
> (lambda (a) (hc-append ((car l) a) (rest a)))
> )
> )
> (print "ERROR:null list in vert")
> )
> )
>
>
> (define (horsep count object spacer a) ; object and spacer are functions taking alists.
> (if (equal? count 1) (object a) ; TODO: zero case
> (ht-append (object a) (spacer a) (horsep ( - count 1 ) object spacer a))
> )
> )
>
> (define (horsepp count object spacer)
> (lambda (a) (horsep count object spacer a))
> )
>
> (define (spacer a)
> (blank 40 40)
> ; (filled-rectangle 40 40 #:color "white")
> )
>
>
> ; Architectural primitives
>
> (define (window a)
> ( let [ (width (lookup 'width a (lambda () 100)))
> ; 10 isn't meant to be realistic. It's meant to be ridiculous as a way of showing that something is wrong in the picture.
> (height (lookup 'height a (lambda () 10)))
> (style (lookup 'style a (lambda () 'framed)))
> ]
> ; (show 'framed style) (show 'width width) (show 'height height)
> (if #t ; (eq? style 'framed)
> ( pin-over
> (filled-rectangle (* width 1.00) (* height 1.00 ) #:color "brown")
> ( * width 0.05 ) ( * height 0.05 )
> (filled-rectangle (* width 0.90) (* height 0.90 ) #:color "black")
> )
> (filled-rectangle (* width 1.00) (* height 1.00 ) #:color "black")
> )
> )
> )
>
> (define (door a)
> (let
> [
> (width
> (begin (lookup 'doorwidth a (lambda () 100)))
> )
> (height (lookup 'doorheight a (lambda () 200)))
> (wodth 200)
> ]
>
> ; (print (list 'in (cons 'wodth wodth) (cons 'width width)))
> (pin-over
> (pin-over
> (begin
> ; (print (list (cons 'wodth wodth) (cons 'width width)))
> (filled-rectangle width height #:color (lookup 'colour a (lambda(a) "gray")))
> )
> (* width 0.05) (* height 0.05)
> (window (binda 'width ( * width 0.9 ) (binda 'height (* height 0.45 ) a)))
> )
> (* width 0.85) (* height 0.6)
> (disk ( * width 0.10) #:color "yellow"))
> )
> )
>
> (define (dww a)
> (let
> [
> (width
> (begin (lookup 'doorwidth a (lambda () 100)))
> )
> (height (lookup 'doorheight a (lambda () 200)))
> (wall (lookup 'wall a (lambda () "lightgreen")))
> ]
> (define fw (bind 'style 'framed(bind 'width ( * width 0.9 ) (bind 'height (* height 0.45 ) window))))
> (define facade (random-ref (list
> (ht-append (spacer a) (door a) (spacer a) (fw a) (spacer a) (fw a) (spacer a))
> (ht-append (spacer a) (fw a) (door a)(spacer a) (fw a))
> (ht-append (fw a) (fw a) (spacer a) (door a))
> )))
> (pin-over (filled-rectangle (pict-width facade) (pict-height facade) #:color wall)
> 0 0
> facade)
> ; (ht-append (door a) (window a) (door a))
> )
> )
>
> (define (4doors a)
> (horsep 4 door spacer a)
> )
>
> (define (8doors a)
> (horsep 8 door spacer a)
> )
>
> ; Test cases
>
> (define colours '( "white" "red" "orange" "yellow" "chartreuse"
> "green" "lightgreen" "darkgreen" "turquoise"
> "blue" "lightblue" "darkblue" "purple" "gray"
> "lightgray:" "darkgray"
> "brown" "lightbrown" "darkbrown"
> "black"))
>
>
>
> (define alist (list
> (cons 'doorwidth 100 )
> (cons 'doorheight 200 )
> (cons 'wodth (lambda (a)
> (lookup 'width a (lambda () 123))
> ))
> (cons 'colour (lambda (a) (random-ref colours)))
> (cons 'highlight (lambda (a) (random-ref colours)))
> (cons 'wall (lambda (a) (random-ref colours)))
> '(style . framed)
> )
> )
>
> ; (lookup 'colour alist (lambda(a) "gray"))
>
> ; (print 'yup)
>
> ; (show 'alist alist)
>
> ; (print 'bar)
> ; (print "\n")
>
> (define (stackdoors a)
> (vc-append
> (4doors a)
> (8doors a)
> ((freezeo 'colour 8doors) a)
> ))
>
>
>
> ; (show-pict ((hor (list door window door)) alist))
>
> ; (show-pict (horsep 3 door window alist))
>
> ; (show-pict (scale (stackdoors alist) 0.5))
>
> (show-pict (scale (dww alist) 0.5))

[Stephen De Gabrielle]

Thank you Hendrik.

All entries are in. Give me a few days to sort through them.

Stephen

To view this discussion on the web visit https://groups.google.com/d/msgid/racket-users/20190831162344.czkcjpxom2etvu4q%40topoi.pooq.com.

--

----