From 542577419324c86f7151634bc42f064e61012327 Mon Sep 17 00:00:00 2001
From: jwilliamson1 <joseph.williamson15@gmail.com>
Date: Sun, 21 Jan 2018 22:28:56 -0500
Subject: [PATCH] made pict2 and macro shit

---
 macros2.rkt |  86 ++++++++++++++++++++
 macros3.rkt | 174 ++++++++++++++++++++++++++++++++++++++++
 macros4.rkt |   5 ++
 pict2.rkt   | 224 ++++++++++++++++++++++++++++++++++++++++++++++++++++
 4 files changed, 489 insertions(+)
 create mode 100644 macros2.rkt
 create mode 100644 macros3.rkt
 create mode 100644 macros4.rkt
 create mode 100644 pict2.rkt

diff --git a/macros2.rkt b/macros2.rkt
new file mode 100644
index 0000000..180d43c
--- /dev/null
+++ b/macros2.rkt
@@ -0,0 +1,86 @@
+#lang racket
+(define-syntax foo
+    (lambda (stx)
+      (syntax "I am foo")))
+
+foo
+
+(define-syntax (also-foo stx)
+    (syntax "I am also foo"))
+
+also-foo
+
+(define-syntax (say-hi stx)
+    #'(displayln "hi"))
+
+say-hi
+
+(define-syntax (show-me stx)
+    (print stx)
+    #'(void))
+> (show-me '(+ 1 2))
+
+(define stx #'(if x (list "true") #f))
+stx
+
+(define huh #'(if x (list "true") #f))
+huh
+
+(syntax-source stx)
+
+(syntax-line stx)
+
+(syntax-column stx)
+
+(syntax-e stx)
+
+(define-syntax (reverse-me stx)
+  (datum->syntax stx (reverse (cdr (syntax->datum stx)))))
+
+(reverse-me "backwards" "am" "i" values)
+
+(define (display-and-return x)
+    (displayln x))
+
+(define (our-if condition true-expr false-expr)
+  (cond [condition true-expr]
+        [else false-expr]))
+(our-if #t
+        (display-and-return "true")
+        (display-and-return "false"))
+(display "v2")
+(newline)
+(define-syntax (our-if-v2 stx)
+  (define xs (syntax->list stx))
+  (datum->syntax stx `(cond[,(cadr xs) ,(caddr xs)]
+                       [else ,(cadddr xs)])))
+
+(our-if-v2 #t
+             (display-and-return "true")
+             (display-and-return "false"))
+
+(require (for-syntax racket/match))
+(define-syntax (our-if-using-match-v2 stx)
+    (match (syntax->list stx)
+      [(list _ condition true-expr false-expr)
+       (datum->syntax stx `(cond [,condition ,true-expr]
+                                 [else ,false-expr]))]))
+(our-if-using-match-v2 #t "true" "false")
+
+(define-syntax (our-if-using-syntax-case stx)
+  (syntax-case stx ()
+    [(_ condition true-expr false-expr)     
+     #'(cond [condition true-expr]
+             [else false-expr])]))
+(our-if-using-syntax-case #f "right" "wrong")
+
+(define-syntax (hyphen-define/wrong1.2 stx)
+  (syntax-case stx ()
+    [(_ a b (args ...) body0 body ...)
+     (syntax-case (datum->syntax stx
+                                 (string->symbol (format "~a-~a" #'a #'b)))
+       ()
+       [name #'(define (name args ...)
+                 body0 body ...)])]))
+
+(hyphen-define/wrong1.2 foo bar () #t)
diff --git a/macros3.rkt b/macros3.rkt
new file mode 100644
index 0000000..ea369af
--- /dev/null
+++ b/macros3.rkt
@@ -0,0 +1,174 @@
+#lang racket
+(require (for-syntax racket/string racket/syntax))
+(define-syntax (hyphen-define/ok2 stx)
+    (syntax-case stx ()
+      [(_ a b (args ...) body0 body ...)
+       (with-syntax ([name (format-id stx "~a-~a" #'a #'b)])
+         #'(define (name args ...)
+             body0 body ...))]))
+
+(hyphen-define/ok2 foo bar () #t)
+(foo-bar)
+
+(define-syntax (hyphen-define* stx)
+  (syntax-case stx ()
+    [(_ (names ...)(args ...) body0 body ...)
+     (let* ([names/sym (map syntax-e (syntax->list #'(names ...)))]
+            [names/str (map symbol->string names/sym)]
+            [name/str (string-join names/str "-")]
+            [name/sym (string->symbol name/str)])
+       (with-syntax ([name (datum->syntax stx name/sym)])
+       #`(define (name args ...)
+           body0 body ...)))]))
+(hyphen-define* (foo bar baz) (v) (* 2 v))
+(foo-bar-baz 50)
+
+(define-syntax (our-struct stx)
+    (syntax-case stx ()
+      [(_ id (fields ...))
+       ; Guard or "fender" expression
+       (for-each (lambda(x)
+                   (unless (identifier? x)
+                     (raise-syntax-error #f "not an identifier" stx x)))
+                 (cons #'id (syntax->list #'(fields ...))))
+       (with-syntax ([pred-id (format-id stx "~a?" #'id)])
+         #`(begin
+             ; Define a constructor.
+             (define (id fields ...)
+               (apply vector (cons 'id  (list fields ...))))
+             ; Define a predicate.
+             (define (pred-id v)
+               (and (vector? v)
+                    (eq? (vector-ref v 0) 'id)))
+             ; Define an accessor for each field.
+             #,@(for/list ([x (syntax->list #'(fields ...))]
+                           [n (in-naturals 1)])
+                  (with-syntax ([acc-id (format-id stx "~a-~a" #'id x)]
+                                [ix n])
+                    #`(define (acc-id v)
+                        (unless (pred-id v)
+                          (error 'acc-id "~a is not a ~a struct" v 'id))
+                        (vector-ref v ix))))))]))
+
+(require rackunit)
+(our-struct foo (a b))
+(define s (foo 1 2))
+(check-true (foo? s))
+(check-false (foo? 1))
+(check-equal? (foo-a s) 1)
+(check-equal? (foo-b s) 2)
+(check-exn exn:fail?
+           (lambda ()(foo-a "furble")))
+
+
+
+;This helper function:
+(define/contract (hash-refs h ks [def #f])
+  ((hash? (listof any/c)) (any/c) . ->* . any)
+  (with-handlers ([exn:fail? (const (cond [(procedure? def)(def)]
+                                          [else def]))])
+    (for/fold ([h h])
+              ([k (in-list ks)])
+      (hash-ref h k))))
+
+
+
+(define-syntax (hash.refs stx)
+  (syntax-case stx ()
+    ;check for no args at all
+    [(_)
+     (raise-syntax-error #f "Expected hash.key0[.key1 ...] [default]" stx #`chain)]
+    ;If the optional 'default' is missing, use #f.
+    [(_ chain)
+     #'(hash.refs chain #f)]
+    [(_ chain default)
+     (unless (identifier? #'chain)
+       (raise-syntax-error #f "Expected hash.key0[.key1 ...] [default]" stx #'chain))
+     (let* ([chain-str (symbol->string (syntax->datum #'chain))]
+            [ids (for/list ([str (in-list (regexp-split #rx"\\." chain-str))])
+                            (format-id #'chain "~a" str))])
+       ;check that we have at lead hash.key
+       (unless (and (>= (length ids) 2)
+                    (not (eq? (syntax-e (cadr ids)) '||)))
+         (raise-syntax-error #f "Expected hash.key" stx #'chain))
+       (with-syntax ([hash-table (car ids)]
+                     [keys (cdr ids)])
+         #'(hash-refs hash-table 'keys default)))]))
+
+(define js (hasheq 'a (hasheq 'b (hasheq 'c "value"))))
+js
+ (hash-ref (hash-ref (hash-ref js 'a) 'b) 'c)
+(hash-refs js '(a b c))
+(hash.refs js.a.b.c)
+
+
+
+;(aif #f (displayln it)(void))
+
+(let ([x "outer"])
+  (let ([x "inner"])
+    (printf "The inner `x' is ~s\n" x))
+  (printf "The outer `x' is ~s\n" x))
+
+(define current-foo (make-parameter "some default value"))
+(current-foo)
+
+(parameterize ([current-foo "I have a new value, for now"])
+    (current-foo))
+(current-foo)
+
+(require racket/stxparam)
+(define-syntax-parameter it
+  (lambda (stx)
+    (raise-syntax-error (syntax-e stx) "can only be used inside aif")))
+(define-syntax-rule (aif condition true-expr false-expr)
+  (let ([tmp condition])
+    (if tmp
+        (syntax-parameterize ([it (make-rename-transformer #'tmp)])
+          true-expr)
+        false-expr)))
+
+(aif 10 (displayln it)(void))
+
+(aif #f (displayln it)(void))
+
+(let ([it 10])
+  it)
+
+(require racket/splicing)
+
+(splicing-let ([x 0])
+  
+  (define (get-x)
+    x))
+
+(get-x)
+
+;(splicing-let ([x 0])
+;  (define (inc)
+;    (set! x (+ x 1)))
+;  (define (dec)
+;    (set! x (- x 1)))
+;  (define (get)
+;    x))
+
+(define-values (inc dec get)
+  (let ([x 0])
+    (values (lambda () ;inc
+              (set! x (+ 1 x)))
+            (lambda () ;dec
+              (set! x (- 1 x)))
+            (lambda () ;get
+              x))))
+
+      
+(inc)
+(dec)
+(dec)
+(get);-1
+
+(define/contract (misuse s)
+  (string? . -> . string?)
+  (string-append s " snazzy suffix"))
+;User of the function:
+(misuse 0)
\ No newline at end of file
diff --git a/macros4.rkt b/macros4.rkt
new file mode 100644
index 0000000..ca3be34
--- /dev/null
+++ b/macros4.rkt
@@ -0,0 +1,5 @@
+#lang typed/racket
+(: misuse (String -> String))
+(define (misuse s)
+  (string-append s " snazzy suffix"))
+(misuse 0)
diff --git a/pict2.rkt b/pict2.rkt
new file mode 100644
index 0000000..ef147d1
--- /dev/null
+++ b/pict2.rkt
@@ -0,0 +1,224 @@
+#lang racket/gui
+(require graphics/graphics)
+(open-graphics)
+(define vp (open-viewport "A Picture Language" 500 500))
+ 
+(define draw (draw-viewport vp))
+(define (clear) ((clear-viewport vp)))
+(define line (draw-line vp))
+
+
+
+(define (make-vect x y)
+  (cons x y))
+ 
+(define (xcor-vect v)
+  (car v))
+ 
+(define (ycor-vect v)
+  (cdr v))
+ 
+(define (add-vect v1 v2)
+  (make-vect
+   (+ (xcor-vect v1) (xcor-vect v2))
+   (+ (ycor-vect v1) (ycor-vect v2))))
+ 
+(define (sub-vect v1 v2)
+  (make-vect
+   (- (xcor-vect v1) (xcor-vect v2))
+   (- (ycor-vect v1) (ycor-vect v2))))
+ 
+(define (scale-vect s v)
+  (make-vect (* s (xcor-vect v))
+             (* s (ycor-vect v))))
+
+(define make-segment cons) 
+ (define start-segment car) 
+ (define end-segment cdr)
+ 
+(define (make-frame origin edge1 edge2)
+  (list origin edge1 edge2))
+ 
+(define (origin-frame frame)
+  (car frame))
+ 
+(define (edge1-frame frame)
+  (cadr frame))
+ 
+(define (edge2-frame frame)
+  (caddr frame))
+ 
+(define (frame-coord-map frame)
+  (lambda (v)
+    (add-vect
+     (origin-frame frame)
+     (add-vect (scale-vect (xcor-vect v)
+                           (edge1-frame frame))
+               (scale-vect (ycor-vect v)
+                           (edge2-frame frame))))))
+
+(define (drawline v1 v2)
+  (line(make-posn (xcor-vect v1)(ycor-vect v1))
+       (make-posn (xcor-vect v2)(ycor-vect v2))))
+ 
+;(define (segments->painter segment-list)
+;  (lambda (frame)
+;    (for-each
+;     (lambda (segment)
+;       (let ((start-coord-map ((frame-coord-map frame) (start-segment segment)))
+;             (end-coord-map ((frame-coord-map frame) (end-segment segment))))
+;       (line
+;        (make-posn (xcor-vect start-coord-map) (ycor-vect start-coord-map))
+;        (make-posn (xcor-vect end-coord-map) (ycor-vect end-coord-map)))))
+;     segment-list)))
+
+(define (segments->painter segment-list)
+  (lambda (frame)
+    (for-each
+     (lambda (segment)
+       (drawline
+        ((frame-coord-map frame) 
+         (start-segment segment))
+        ((frame-coord-map frame) 
+         (end-segment segment))))
+     segment-list)))
+
+(define x-painter
+  (segments->painter
+   (list
+    (make-segment (make-vect 0 0)
+                  (make-vect 1 1))
+    (make-segment (make-vect 0 1)
+                  (make-vect 1 0)))))
+ 
+(define unit-frame (make-frame (make-vect 0 500) (make-vect 500 0) (make-vect 0 -500)))
+;(x-painter unit-frame)
+
+(define (transform-painter 
+         painter origin corner1 corner2)
+  (lambda (frame)
+    (let ((m (frame-coord-map frame)))
+      (let ((new-origin (m origin)))
+        (painter (make-frame new-origin
+                  (sub-vect (m corner1) 
+                            new-origin)
+                  (sub-vect (m corner2)
+                            new-origin)))))))
+
+(define wave 
+   (segments->painter (list 
+                       (make-segment (make-vect .25 0) (make-vect .35 .5)) 
+                       (make-segment (make-vect .35 .5) (make-vect .3 .6)) 
+                       (make-segment (make-vect .3 .6) (make-vect .15 .4)) 
+                       (make-segment (make-vect .15 .4) (make-vect 0 .65)) 
+                       (make-segment (make-vect 0 .65) (make-vect 0 .85)) 
+                       (make-segment (make-vect 0 .85) (make-vect .15 .6)) 
+                       (make-segment (make-vect .15 .6) (make-vect .3 .65)) 
+                       (make-segment (make-vect .3 .65) (make-vect .4 .65)) 
+                       (make-segment (make-vect .4 .65) (make-vect .35 .85)) 
+                       (make-segment (make-vect .35 .85) (make-vect .4 1)) 
+                       (make-segment (make-vect .4 1) (make-vect .6 1)) 
+                       (make-segment (make-vect .6 1) (make-vect .65 .85)) 
+                       (make-segment (make-vect .65 .85) (make-vect .6 .65)) 
+                       (make-segment (make-vect .6 .65) (make-vect .75 .65)) 
+                       (make-segment (make-vect .75 .65) (make-vect 1 .35)) 
+                       (make-segment (make-vect 1 .35) (make-vect 1 .15)) 
+                       (make-segment (make-vect 1 .15) (make-vect .6 .45)) 
+                       (make-segment (make-vect .6 .45) (make-vect .75 0)) 
+                       (make-segment (make-vect .75 0) (make-vect .6 0)) 
+                       (make-segment (make-vect .6 0) (make-vect .5 .3)) 
+                       (make-segment (make-vect .5 .3) (make-vect .4 0)) 
+                       (make-segment (make-vect .4 0) (make-vect .25 0)) 
+                       ))) 
+ ;George! 
+
+(define (flip-vert painter)
+  (transform-painter 
+   painter
+   (make-vect 0.0 1.0)   ; new origin
+   (make-vect 1.0 1.0)   ; new end of edge1
+   (make-vect 0.0 0.0))) ; new end of edge2
+
+(define (flip-horiz painter)
+  (transform-painter
+   painter
+   (make-vect 1.0 0.0); new origin
+   (make-vect 0.0 0.0)
+   (make-vect 1.0 1.0)))
+
+(define (shrink-to-upper-right painter)
+  (transform-painter painter
+                     (make-vect 0.5 0.5)
+                     (make-vect 1.0 0.5)
+                     (make-vect 0.5 1.0)))
+
+(define (rotate90 painter)
+  (transform-painter painter
+                     (make-vect 1.0 0.0)
+                     (make-vect 1.0 1.0)
+                     (make-vect 0.0 0.0)))
+
+(define (rotate180 painter)
+  (flip-vert painter))
+
+(define (rotate270 painter)
+  (flip-horiz (rotate90 painter)))
+                     
+
+(define (squash-inwards painter)
+  (transform-painter painter
+                     (make-vect 0.0 0.0)
+                     (make-vect 0.65 0.35)
+                     (make-vect 0.35 0.65)))
+
+;((squash-inwards(shrink-to-upper-right(flip-vert( rotate90 wave))))unit-frame)
+;(wave unit-frame)
+;((rotate180(rotate180 wave))unit-frame)
+
+;((rotate180(rotate180 wave))unit-frame)
+;((rotate90 wave)unit-frame)
+;((rotate270 wave)unit-frame)
+
+(define (beside painter1 painter2)
+  (let ((split-point (make-vect 0.5 0.0)))
+    (let ((paint-left  (transform-painter 
+                        painter1
+                        (make-vect 0.0 0.0)
+                        split-point
+                        (make-vect 0.0 1.0)))
+          (paint-right (transform-painter
+                        painter2
+                        split-point
+                        (make-vect 1.0 0.0)
+                        (make-vect 0.5 1.0))))
+      (lambda (frame)
+        (paint-left frame)
+        (paint-right frame)))))
+
+(define (below painter1 painter2)
+  (let ((split-point (make-vect 0.0 0.5)))
+    (let  ((paint-top (transform-painter
+                       painter1
+                       split-point
+                       
+                       (make-vect 1.0 0.5)
+                       (make-vect 0.0 1.0)))
+           (paint-bottom (transform-painter
+                          painter2
+                          (make-vect 0.0 0.0)
+                          (make-vect 1.0 0.0)
+                          split-point
+                          )))
+    (lambda(frame)
+      (paint-top frame)
+      (paint-bottom frame)))))
+
+(define (below-rot painter1 painter2)
+  (rotate90 (beside (rotate270 painter2)(rotate270 painter1))))
+
+((below-rot wave wave)unit-frame)
+
+;((below wave wave)unit-frame)
+                                       
+                                         
+    
\ No newline at end of file