334 lines
13 KiB
Scheme
334 lines
13 KiB
Scheme
#| Class Representation:
|
|
|
|
Class = (list String (Listof Field))
|
|
Field = (list String String)
|
|
|
|
|#
|
|
(module draw-txt mzscheme
|
|
(require (lib "etc.ss")
|
|
(lib "list.ss"))
|
|
|
|
;; Class (Listof Classes) -> (Listof String)
|
|
(define (class-union-to-strings utype variants)
|
|
(let* ([ac (class-to-strings utype)]
|
|
[classes (classes-to-strings variants (car utype))]
|
|
[v (flatten-string-matrix classes)]
|
|
[Lv (string-length (first v))]
|
|
[the-core
|
|
(append
|
|
(center-picture Lv ac)
|
|
(center-picture Lv REFINEMENT-ARROW)
|
|
(center-picture Lv (refinement-connectors classes))
|
|
v)]
|
|
[foo 0])
|
|
(map (lambda (x)
|
|
(set! foo (+ foo 1))
|
|
(cond
|
|
[(> foo 2) (string-append x "|")]
|
|
[(= foo 1) x]
|
|
[(= foo 2) (replace-end-with-back-arrow x)]))
|
|
the-core)))
|
|
|
|
;; String -> String
|
|
;; add the containment arrow to an abstract class from the right fringe
|
|
(define (replace-end-with-back-arrow x0)
|
|
(list->string
|
|
(reverse!
|
|
(cons #\+
|
|
(let loop ([x (reverse (string->list x0))])
|
|
(cond
|
|
[(char=? (cadr x) #\|) (cons #\< (cdr x))]
|
|
[else (cons #\- (loop (cdr x)))]))))))
|
|
|
|
;; (Listof String) -> (Listof String)
|
|
(define (refinement-connectors class-pictures)
|
|
(let ([center-char
|
|
(lambda (line c l r)
|
|
(car (center-picture (string-length line) (list c) l r)))])
|
|
(list
|
|
(string-append
|
|
(center-char (caar class-pictures) "+" #\space #\-)
|
|
(let loop ([cp (rest class-pictures)])
|
|
(cond
|
|
[(null? (rest cp))
|
|
(center-char (caar cp) "+" #\- #\space)]
|
|
[else (string-append (center-char (caar cp) "+" #\- #\-)
|
|
(loop (rest cp)))])))
|
|
(foldr (lambda (f r)
|
|
(string-append (car (center-picture (string-length (car f)) (list "|"))) r))
|
|
""
|
|
class-pictures)
|
|
)))
|
|
|
|
;; Number (Listof String) -> (Listof String)
|
|
(define center-picture
|
|
(opt-lambda (Lv ac (l #\space)[r #\space])
|
|
(let* ([delta (- Lv (string-length (first ac)))]
|
|
[lft (quotient delta 2)])
|
|
(map (pad-lines (make-string lft l) (make-string (- delta lft) r)) ac))))
|
|
|
|
(define REFINEMENT-ARROW
|
|
(list "/ \\"
|
|
"---"
|
|
" | "))
|
|
|
|
;; Class String *-> String
|
|
(define (classes-draw classes . super)
|
|
(strings->string-as-lines (apply classes-to-strings classes super)))
|
|
|
|
;; Class -> String
|
|
(define (class-draw class)
|
|
(strings->string-as-lines (class-to-strings class)))
|
|
|
|
;; (Listof Class) String *-> (Listof (Listof String))
|
|
;; take a list of classes and produce a single "line" (listof string-lines)
|
|
(define (classes-to-strings classes0 . super)
|
|
(let* (;; (Listof (Listof String))
|
|
[classes (map (lambda (c) (apply class-to-strings c super)) classes0)]
|
|
[L (apply max (map length classes))]
|
|
[FOO " "]
|
|
[classes (foldr (lambda (class-los is-self-recursive rest)
|
|
(if (null? super)
|
|
(map (pad-lines FOO FOO)
|
|
(if (>= (length class-los) L)
|
|
class-los
|
|
(pad-class-with-blank-lines L class-los)))
|
|
(cons
|
|
(append
|
|
(map (pad-lines FOO FOO)
|
|
(if (>= (length class-los) L)
|
|
class-los
|
|
(pad-class-with-blank-lines L class-los)))
|
|
(list
|
|
(case is-self-recursive
|
|
[(long)
|
|
(string-append
|
|
"--"
|
|
(make-string (string-length (first class-los)) #\-)
|
|
CROSS
|
|
(if (null? rest) "--" ""))]
|
|
[(short)
|
|
(string-append
|
|
" "
|
|
(make-string (string-length (first class-los)) #\space)
|
|
CROSS
|
|
(if (null? rest) "--" ""))]
|
|
[(conn)
|
|
(string-append
|
|
"--"
|
|
(make-string (string-length (first class-los)) #\-)
|
|
NOCROSS
|
|
(if (null? rest) "--" ""))
|
|
]
|
|
[(none)
|
|
(string-append
|
|
" "
|
|
(make-string (string-length (first class-los)) #\space)
|
|
FOO)])))
|
|
rest)))
|
|
'()
|
|
classes
|
|
(let loop ([c classes0][prior #f])
|
|
(cond
|
|
[(null? c) '()]
|
|
[else (let ([self-recursive (apply is-recursive? (car c) super)])
|
|
(cond
|
|
[(and self-recursive prior) (cons 'long (loop (cdr c) #t))]
|
|
[self-recursive (cons 'short (loop (cdr c) #t))]
|
|
[prior (cons 'conn (loop (cdr c) #t))]
|
|
[else (cons 'none (loop (cdr c) #f))]))])))])
|
|
classes))
|
|
|
|
|
|
|
|
(define is-recursive?
|
|
(case-lambda
|
|
[(class) #f]
|
|
[(class super)
|
|
(let* ([name (first class)]
|
|
[fields (second class)]
|
|
[types (map first fields)])
|
|
(member super types))]))
|
|
|
|
|
|
(define CROSS "-+-")
|
|
(define NOCROSS "---")
|
|
|
|
;; Number (Cons String (Listof String)) -> (Listof String)
|
|
(define (pad-class-with-blank-lines n l)
|
|
(let ([blanks (make-string (string-length (first l)) #\space)])
|
|
(append l (build-list (- n (length l)) (lambda (i) blanks)))))
|
|
|
|
;; Class String *-> (Listof String)
|
|
;; the presence of super suggests that we want to draw a line to super
|
|
(define (class-to-strings class . super)
|
|
(let* ([is-super? (if (null? super)
|
|
(lambda (x) false)
|
|
(lambda (x) (string=? (car super) x)))]
|
|
[name (first class)]
|
|
[fields (second class)]
|
|
[types (map first fields)]
|
|
[names (map second fields)]
|
|
[fields (create-field-declarations fields)]
|
|
[width (width-class name fields)]
|
|
[separat (make-separator-line width)]
|
|
[separat-hasa (make-separator-line width #t)]
|
|
[start-hasa #f])
|
|
(cond
|
|
[(and (cons? super) (ormap is-super? types))
|
|
`(,separat
|
|
,((make-line width) name)
|
|
,separat
|
|
,@(map (lambda (line type)
|
|
(cond
|
|
[(is-super? type) (set! start-hasa #t) [(make-line width HOOK) line]]
|
|
[start-hasa [(make-line width HASA) line]]
|
|
[else ((make-line width) line)]))
|
|
fields types)
|
|
,separat-hasa)]
|
|
[else
|
|
`(,separat
|
|
,((make-line width) name)
|
|
,separat
|
|
,@(map (make-line width) fields)
|
|
,separat)])))
|
|
|
|
;; (Listof Field) -> (Listof String)
|
|
(define (create-field-declarations fields)
|
|
(map (lambda (f) (string-append (string-append (first f) " " (second f))))
|
|
fields))
|
|
|
|
;; String Boolean *-> String
|
|
(define (make-separator-line width . hasa)
|
|
(string-append LFT+ (make-string (- width (string-length LFT+) (string-length RGT+)) #\-)
|
|
(if (null? hasa) RGT+ HASA+)))
|
|
|
|
;; Number String -> String
|
|
;; make one line in class of width from txt
|
|
(define (make-line width . rgt)
|
|
(lambda (txt)
|
|
(string-append
|
|
LEFT
|
|
txt
|
|
(make-string
|
|
(- width (string-length txt) (string-length LEFT) (string-length RIGHT))
|
|
#\space)
|
|
(if (null? rgt) RIGHT (car rgt)))))
|
|
|
|
(define LEFT " | ")
|
|
(define LFT+ " +-")
|
|
(define RIGHT " | ")
|
|
(define HOOK " |-o") ; (= (string-length RIGHT) (string-length HOOK))
|
|
(define RGT+ "-+ ") ; (= (string-length RIGHT) (string-length RGT+))
|
|
(define HASA " | |") ; (= (string-length RIGHT) (string-length HASA))
|
|
(define HASA+ "-+ |") ; (= (string-length RIGHT) (string-length RGT+))
|
|
|
|
;; String (Cons String (Listof String)) -> Number
|
|
;; compute width of class as the widest field/name
|
|
(define (width-class name fields)
|
|
(+ (string-length LEFT)
|
|
;; longest field spec of name/class and fields
|
|
(apply max (map string-length (cons name fields)))
|
|
(string-length RIGHT)))
|
|
|
|
;; String String -> (String -> String)
|
|
;; add lft and rgt to txt
|
|
(define (pad-lines lft rgt) (lambda (txt) (string-append lft txt rgt)))
|
|
|
|
;; (Listof (Listof String)) -> (Listof String)
|
|
;; contract: (apply = (map length smatrix))
|
|
;; this requires Pretty Big, it could be written in Intermediate
|
|
(define (flatten-string-matrix smatrix)
|
|
(apply map (lambda l (apply string-append l)) smatrix))
|
|
|
|
;; (Listof String) -> String
|
|
;; turn the list of strings into a single string, separating lines with newline
|
|
(define (strings->string-as-lines s)
|
|
(apply string-append (map (lambda (x) (string-append x "\n")) s)))
|
|
|
|
;; Basic Tests:
|
|
|
|
|
|
(equal?
|
|
(flatten-string-matrix
|
|
(list (list "a1" "a2" "a3") (list "b1" "b2" "b3") (list "c1" "c2" "c3")))
|
|
(list "a1b1c1" "a2b2c2" "a3b3c3"))
|
|
|
|
;; Tests
|
|
|
|
|
|
(define aTrain (list"Train"'(("int" "capacity") ("hello" "world"))))
|
|
(define sTrain (list"Train"'(("int" "capacity"))))
|
|
|
|
(test== (width-class (car aTrain) (create-field-declarations (cadr aTrain)))
|
|
(+ 12 (string-length LEFT) (string-length RIGHT)))
|
|
|
|
(test== ([make-line (+ 12 (string-length LEFT) (string-length RIGHT))] "int capacity")
|
|
" | int capacity | ")
|
|
|
|
(test== (make-separator-line (+ 12 (string-length LEFT) (string-length RIGHT)))
|
|
" +--------------+ ")
|
|
|
|
(define expected-class
|
|
(list
|
|
" +--------------+ \n"
|
|
" | Train | \n"
|
|
" +--------------+ \n"
|
|
" | int capacity | \n"
|
|
" | hello world | \n"
|
|
" +--------------+ \n"))
|
|
|
|
(test== (class-draw aTrain)
|
|
(apply string-append expected-class))
|
|
|
|
(test== (classes-to-strings (list sTrain aTrain))
|
|
'((" +--------------+ "
|
|
" | Train | "
|
|
" +--------------+ "
|
|
" | int capacity | "
|
|
" +--------------+ "
|
|
" ")
|
|
(" +--------------+ "
|
|
" | Train | "
|
|
" +--------------+ "
|
|
" | int capacity | "
|
|
" | hello world | "
|
|
" +--------------+ ")))
|
|
|
|
;; Union: ARiver = Source(Location) | Confluence(Location, ARiver, ARiver)
|
|
(define ARiver
|
|
(list "ARiver" '()))
|
|
(define Source
|
|
(list "Source" '(("Location" "loc"))))
|
|
(define Confluence
|
|
(list "Confluence" '(("Location" "loc") ("ARiver" "left") ("ARiver" "right"))))
|
|
|
|
(test== (strings->string-as-lines
|
|
(class-union-to-strings ARiver (list Source Confluence)))
|
|
(strings->string-as-lines
|
|
'(" +--------+ "
|
|
" | ARiver |<---------------------+"
|
|
" +--------+ |"
|
|
" +--------+ |"
|
|
" / \\ |" ;; note escape
|
|
" --- |"
|
|
" | |"
|
|
" +--------------------------+ |"
|
|
" | | |"
|
|
" +--------------+ +--------------+ |"
|
|
" | Source | | Confluence | |"
|
|
" +--------------+ +--------------+ |"
|
|
" | Location loc | | Location loc | |"
|
|
" +--------------+ | ARiver left |-o |"
|
|
" | ARiver right |-o |"
|
|
" +--------------+ | |"
|
|
" -+----|")))
|
|
|
|
(test== (replace-end-with-back-arrow "| ARiver | ")
|
|
"| ARiver |<----+"
|
|
"replace end with back arrow")
|
|
|
|
(printf "~a" (strings->string-as-lines (class-union-to-strings ARiver (list Source Confluence))))
|
|
|
|
)
|