Skip to content

Commit

Permalink
incremental checkin - adding a class thing (viewer not working yet)
Browse files Browse the repository at this point in the history
  • Loading branch information
@alanb2718
alanb2718 committed Mar 1, 2016
1 parent 23940ce commit 0f30cb8
Show file tree
Hide file tree
Showing 22 changed files with 662 additions and 605 deletions.
28 changes: 14 additions & 14 deletions applications/draw-binary-tree.rkt
View file
Original file line number Diff line number Diff line change
Expand Up @@ -4,7 +4,7 @@
(require "../core/wallingford.rkt")
(require "../applications/geothings.rkt")

(wally-clear)
(define picture (new thing%))

(define frame (new frame%
[label "Binary Tree Example"]
Expand Down Expand Up @@ -35,8 +35,8 @@
(let ([p (make-point)])
(set! tree-points (cons p tree-points))
;; Dirty Hack to make sure values are nice
(always (<= 0 (point-x p)))
(always (<= 0 (point-y p)))
(always (<= 0 (point-x p)) #:owner picture)
(always (<= 0 (point-y p)) #:owner picture)
;; End Hack
p))

Expand Down Expand Up @@ -68,38 +68,38 @@

; 1. separation of bottom points (by 2x x-spacing)
(always (<= (+ branch-x-distrib (point-x lp))
(point-x rp)))
(point-x rp)) #:owner picture)
(always (equal? (+ branch-x-distrib (point-x lp))
(point-x rp))
#:priority low)
#:priority low #:owner picture)

; 2. bottom points are equally distributed around top point
(always (equal? (- (point-x tp) (point-x lp))
(- (point-x rp) (point-x tp))))
(- (point-x rp) (point-x tp))) #:owner picture)

; 3. Top point is always 30 above left and right point
(always (equal? (+ branch-y-spacing (point-y tp))
(point-y lp)))
(point-y lp)) #:owner picture)
(always (equal? (+ branch-y-spacing (point-y tp))
(point-y rp)))
(point-y rp)) #:owner picture)

(when lt
; 7. Rightmost point in left subtree is left of top point
(always (<= (+ branch-x-spacing (point-x (branch-rightmost lt)))
(point-x tp)))
(point-x tp)) #:owner picture)
(always (equal? (+ branch-x-spacing (point-x (branch-rightmost lt)))
(point-x tp))
#:priority low)
#:priority low #:owner picture)
)


(when rt
; 9. Leftmost point in right subtree is right of top point
(always (<= (+ branch-x-spacing (point-x tp))
(point-x (branch-leftmost rt))))
(point-x (branch-leftmost rt))) #:owner picture)
(always (equal? (+ branch-x-spacing (point-x tp))
(point-x (branch-leftmost rt)))
#:priority low)
#:priority low #:owner picture)
)

b))
Expand All @@ -120,7 +120,7 @@


(define (show-tree bt)
(show-tree-recur (evaluate bt)))
(show-tree-recur (send picture wally-evaluate bt)))

(define (show-tree-recur bt)
(let ([lt (branch-lt bt)]
Expand All @@ -137,7 +137,7 @@
(define test (binary-tree 4 300 50))

(printf "solving\n")
(time (wally-solve))
(time (send picture solve))
(printf "solved\n")

(define (showtest)
Expand Down
12 changes: 6 additions & 6 deletions applications/draw-midpointline.rkt
View file
Original file line number Diff line number Diff line change
Expand Up @@ -4,11 +4,11 @@
(require "../core/wallingford.rkt")
(require "../applications/geothings.rkt")

(wally-clear)
(define mpl (make-midpointline-with-stays))
(define picture (new thing%))
(define mpl (make-midpointline-with-stays picture))
; initialize the line's location
(assert (equal? (midpointline-line mpl) (line (point 10 10) (point 200 250))))
(wally-solve)
(send picture solve)

(define frame (new frame%
[label "Moving one endpoint of a midpoint line"]
Expand All @@ -21,7 +21,7 @@
(lambda (canvas dc)
(send dc set-pen "black" 1 'solid)
(send dc set-brush "black" 'solid)
(showthing (evaluate mpl) dc))]))
(showthing (send picture wally-evaluate mpl) dc))]))
(define dc (send canv get-dc))

(send frame show #t)
Expand All @@ -30,6 +30,6 @@
(let ((x (+ i 10))
(y (+ (* i 4) 20)))
(assert (equal? (line-end1 (midpointline-line mpl)) (point x y)))
(wally-solve)
(send picture solve)
(send dc clear)
(showthing (evaluate mpl) dc)))
(showthing (send picture wally-evaluate mpl) dc)))
62 changes: 31 additions & 31 deletions applications/draw-quadrilateral.rkt
View file
Original file line number Diff line number Diff line change
Expand Up @@ -4,35 +4,35 @@
(require "../core/wallingford.rkt")
(require "../applications/geothings.rkt")

(wally-clear)
(define side1 (make-midpointline-with-stays))
(define side2 (make-midpointline-with-stays))
(define side3 (make-midpointline-with-stays))
(define side4 (make-midpointline-with-stays))
(define picture (new thing%))
(define side1 (make-midpointline-with-stays picture))
(define side2 (make-midpointline-with-stays picture))
(define side3 (make-midpointline-with-stays picture))
(define side4 (make-midpointline-with-stays picture))
(define mid1 (make-line))
(define mid2 (make-line))
(define mid3 (make-line))
(define mid4 (make-line))
; connect everything up
(always (equal? (line-end2 (midpointline-line side1)) (line-end1 (midpointline-line side2))))
(always (equal? (line-end2 (midpointline-line side2)) (line-end1 (midpointline-line side3))))
(always (equal? (line-end2 (midpointline-line side3)) (line-end1 (midpointline-line side4))))
(always (equal? (line-end2 (midpointline-line side4)) (line-end1 (midpointline-line side1))))
(always (equal? (midpointline-midpoint side1) (line-end1 mid1)))
(always (equal? (midpointline-midpoint side1) (line-end2 mid4)))
(always (equal? (midpointline-midpoint side2) (line-end1 mid2)))
(always (equal? (midpointline-midpoint side2) (line-end2 mid1)))
(always (equal? (midpointline-midpoint side3) (line-end1 mid3)))
(always (equal? (midpointline-midpoint side3) (line-end2 mid2)))
(always (equal? (midpointline-midpoint side4) (line-end1 mid4)))
(always (equal? (midpointline-midpoint side4) (line-end2 mid3)))
(always (equal? (line-end2 (midpointline-line side1)) (line-end1 (midpointline-line side2))) #:owner picture)
(always (equal? (line-end2 (midpointline-line side2)) (line-end1 (midpointline-line side3))) #:owner picture)
(always (equal? (line-end2 (midpointline-line side3)) (line-end1 (midpointline-line side4))) #:owner picture)
(always (equal? (line-end2 (midpointline-line side4)) (line-end1 (midpointline-line side1))) #:owner picture)
(always (equal? (midpointline-midpoint side1) (line-end1 mid1)) #:owner picture)
(always (equal? (midpointline-midpoint side1) (line-end2 mid4)) #:owner picture)
(always (equal? (midpointline-midpoint side2) (line-end1 mid2)) #:owner picture)
(always (equal? (midpointline-midpoint side2) (line-end2 mid1)) #:owner picture)
(always (equal? (midpointline-midpoint side3) (line-end1 mid3)) #:owner picture)
(always (equal? (midpointline-midpoint side3) (line-end2 mid2)) #:owner picture)
(always (equal? (midpointline-midpoint side4) (line-end1 mid4)) #:owner picture)
(always (equal? (midpointline-midpoint side4) (line-end2 mid3)) #:owner picture)

; initialize the locations of the sides (the midpoints and parallelogram sides can take care of themselves)
(assert (equal? (line-end1 (midpointline-line side1)) (point 250 50)))
(assert (equal? (line-end1 (midpointline-line side2)) (point 550 250)))
(assert (equal? (line-end1 (midpointline-line side3)) (point 250 550)))
(assert (equal? (line-end1 (midpointline-line side4)) (point 50 250)))
(wally-solve)
(assert (equal? (line-end1 (midpointline-line side2)) (point 550 250)) #:owner picture)
(assert (equal? (line-end1 (midpointline-line side3)) (point 250 550)) #:owner picture)
(assert (equal? (line-end1 (midpointline-line side4)) (point 50 250)) #:owner picture)
(send picture solve)

(define frame (new frame%
[label "Moving one endpoint of a midpoint line"]
Expand All @@ -49,14 +49,14 @@
(define dc (send canv get-dc))

(define (showquad)
(define s1 (evaluate (midpointline-line side1)))
(define s2 (evaluate (midpointline-line side2)))
(define s3 (evaluate (midpointline-line side3)))
(define s4 (evaluate (midpointline-line side4)))
(define m1 (evaluate mid1))
(define m2 (evaluate mid2))
(define m3 (evaluate mid3))
(define m4 (evaluate mid4))
(define s1 (send picture wally-evaluate (midpointline-line side1)))
(define s2 (send picture wally-evaluate (midpointline-line side2)))
(define s3 (send picture wally-evaluate (midpointline-line side3)))
(define s4 (send picture wally-evaluate (midpointline-line side4)))
(define m1 (send picture wally-evaluate mid1))
(define m2 (send picture wally-evaluate mid2))
(define m3 (send picture wally-evaluate mid3))
(define m4 (send picture wally-evaluate mid4))
(send dc clear)
(showthing s1 dc)
(showthing s2 dc)
Expand All @@ -72,6 +72,6 @@
(for ([i 50])
(let ((x (+ (* i 4) 250))
(y (+ (* i 12) 50)))
(assert (equal? (line-end1 (midpointline-line side1)) (point x y)))
(wally-solve)
(assert (equal? (line-end1 (midpointline-line side1)) (point x y)) #:owner picture)
(send picture solve)
(showquad)))
53 changes: 27 additions & 26 deletions applications/electrical-things-dynamic.rkt
View file
Original file line number Diff line number Diff line change
Expand Up @@ -18,59 +18,60 @@
; This is currently enforced by the programmer - it would be cool for this to
; simply be a constraint that gets maintained automatically.

(define (make-node)
(define-symbolic* v number?)
(define (make-node circuit)
(define-symbolic* v real?)
(define nd (node v null))
; the sum of the currents flowing into this node is 0 (Kirchhoff's first law)
; this is a dynamic constraint, so that it will work if leads are connected or disconnected
; this constraint will stick around for nodes that are no longer used - this may lead to
; efficiency problems after a while. (Solutions: explicitly remove old constraints, or
; garbage collect ones that aren't applicable to any visible objects.)
(always* (equal? 0 (foldl + 0 (map lead-current (node-leads nd)))))
(always* (equal? 0 (foldl + 0 (map lead-current (node-leads nd)))) #:owner circuit)
nd)

; make a new lead that connects to the given node, or create a new node if needed
(define (make-lead [nd null])
(define-symbolic* i number?)
(define mynode (if (null? nd) (make-node) nd))
(define (make-lead circuit [nd null])
(define-symbolic* i real?)
(define mynode (if (null? nd) (make-node circuit) nd))
(define ld (lead mynode i))
(set-node-leads! mynode (cons ld (node-leads mynode)))
ld)

(define (make-battery [intv null])
(define-symbolic* internal-voltage number?)
(define plus (make-lead))
(define minus (make-lead))
(define (make-battery circuit [intv null])
(define-symbolic* internal-voltage real?)
(define plus (make-lead circuit))
(define minus (make-lead circuit))
; since we are allowing nodes to be changed we need to make the first of these constraints dynamic as well
; (the second one doesn't actually need to be dynamic but I just left it that way for consistency)
(always* (equal? internal-voltage (- (node-voltage (lead-node plus)) (node-voltage (lead-node minus)))))
(always* (equal? 0 (+ (lead-current plus) (lead-current minus))))
(unless (null? intv) (always (equal? internal-voltage intv)))
(always* (equal? internal-voltage (- (node-voltage (lead-node plus)) (node-voltage (lead-node minus)))) #:owner circuit)
(always* (equal? 0 (+ (lead-current plus) (lead-current minus))) #:owner circuit)
(unless (null? intv) (always (equal? internal-voltage intv) #:owner circuit))
(battery plus minus internal-voltage))

(define (make-resistor [r null])
(define-symbolic* resistance number?)
(define lead1 (make-lead))
(define lead2 (make-lead))
(define (make-resistor circuit [r null])
(define-symbolic* resistance real?)
(define lead1 (make-lead circuit))
(define lead2 (make-lead circuit))
; similarly the first of these constraints needs to be dynamic
(always* (equal? (- (node-voltage (lead-node lead2)) (node-voltage (lead-node lead1))) (* resistance (lead-current lead1))))
(always* (equal? 0 (+ (lead-current lead1) (lead-current lead2))))
(unless (null? r) (always (equal? resistance r)))
(always* (equal? (- (node-voltage (lead-node lead2)) (node-voltage (lead-node lead1))) (* resistance (lead-current lead1)))
#:owner circuit)
(always* (equal? 0 (+ (lead-current lead1) (lead-current lead2))) #:owner circuit)
(unless (null? r) (always (equal? resistance r) #:owner circuit))
(resistor lead1 lead2 resistance))

(define (make-ground)
(define ld (make-lead))
(always* (equal? 0 (node-voltage (lead-node ld))))
(always* (equal? 0 (lead-current ld)))
(define (make-ground circuit)
(define ld (make-lead circuit))
(always* (equal? 0 (node-voltage (lead-node ld))) #:owner circuit)
(always* (equal? 0 (lead-current ld)) #:owner circuit)
ld)

; Connect a list of leads together by making a new node and plugging that node into each lead.
; It shouldn't matter if some of the leads are already connected - we make a fresh node
; and use that. (The old nodes will have always* Kirchhoff's law constraints, which will
; persist. This should be harmless although could be a cause of inefficiencies.)
(define (connect leads)
(define (connect circuit leads)
(let ((all-leads null)
(new-node (make-node)))
(new-node (make-node circuit)))
; find all the existing leads that are connected to leads in 'leads' and put them in all-leads
(for ([ld1 leads])
(for ([ld2 (node-leads (lead-node ld1))])
Expand Down
48 changes: 24 additions & 24 deletions applications/electrical-things.rkt
View file
Original file line number Diff line number Diff line change
Expand Up @@ -12,39 +12,39 @@
(struct battery (plus minus internal-voltage) #:transparent)
(struct resistor (lead1 lead2 resistance) #:transparent)

(define (make-lead)
(define-symbolic* v i number?)
(define (make-lead circuit)
(define-symbolic* v i real?)
(lead v i))

(define (make-battery [intv null])
(define-symbolic* internal-voltage number?)
(define plus (make-lead))
(define minus (make-lead))
(always (equal? internal-voltage (- (lead-voltage plus) (lead-voltage minus))))
(always (equal? 0 (+ (lead-current plus) (lead-current minus))))
(define (make-battery circuit [intv null])
(define-symbolic* internal-voltage real?)
(define plus (make-lead circuit))
(define minus (make-lead circuit))
(always (equal? internal-voltage (- (lead-voltage plus) (lead-voltage minus))) #:owner circuit)
(always (equal? 0 (+ (lead-current plus) (lead-current minus))) #:owner circuit)
; if the intv argument is present, fix the internal voltage
(unless (null? intv) (always (equal? internal-voltage intv)))
(unless (null? intv) (always (equal? internal-voltage intv) #:owner circuit))
(battery plus minus internal-voltage))

(define (make-resistor [r null])
(define-symbolic* resistance number?)
(define lead1 (make-lead))
(define lead2 (make-lead))
(always (equal? (- (lead-voltage lead2) (lead-voltage lead1)) (* resistance (lead-current lead1))))
(always (equal? 0 (+ (lead-current lead1) (lead-current lead2))))
(define (make-resistor circuit [r null])
(define-symbolic* resistance real?)
(define lead1 (make-lead circuit))
(define lead2 (make-lead circuit))
(always (equal? (- (lead-voltage lead2) (lead-voltage lead1)) (* resistance (lead-current lead1))) #:owner circuit)
(always (equal? 0 (+ (lead-current lead1) (lead-current lead2))) #:owner circuit)
; if the resistance argument is present, fix the resistance of this resistor
(unless (null? r) (always (equal? resistance r)))
(resistor lead1 lead2 resistance))
(unless (null? r) (always (equal? resistance r) #:owner circuit))
(resistor lead1 lead2 resistance))

(define (make-ground)
(define ld (make-lead))
(always (equal? 0 (lead-voltage ld)))
(always (equal? 0 (lead-current ld)))
(define (make-ground circuit)
(define ld (make-lead circuit))
(always (equal? 0 (lead-voltage ld)) #:owner circuit)
(always (equal? 0 (lead-current ld)) #:owner circuit)
ld)

(define (connect leads)
(define (connect circuit leads)
(let ((lead1 (car leads))
(others (cdr leads)))
(for ([ld others])
(always (equal? (lead-voltage lead1) (lead-voltage ld))))
(always (equal? 0 (foldl + 0 (map lead-current leads))))))
(always (equal? (lead-voltage lead1) (lead-voltage ld)) #:owner circuit))
(always (equal? 0 (foldl + 0 (map lead-current leads))) #:owner circuit)))
Loading

0 comments on commit 0f30cb8

Please sign in to comment.