moved the first-line-text stuff into the framework, added docs, added a pref to disable it and made it work a little bit better with check syntax
svn: r11477
This commit is contained in:
Robby Findler
parent
06c5e975c2
commit
6d34eaf333
|
|
@ -1,84 +1,85 @@
|
|||
(module acks mzscheme
|
||||
(provide get-general-acks
|
||||
get-translating-acks
|
||||
get-authors)
|
||||
|
||||
(define (get-authors)
|
||||
(get-general-acks))
|
||||
|
||||
(define (get-general-acks)
|
||||
(string-append
|
||||
"The following individuals contributed to the implementation"
|
||||
" and documentation of PLT Scheme: "
|
||||
"Yavuz Arkun, "
|
||||
"Ian Barland, "
|
||||
"Eli Barzilay, "
|
||||
"Gann Bierner, "
|
||||
"Filipe Cabecinhas, "
|
||||
"Richard Cleis, "
|
||||
"John Clements, "
|
||||
"Richard Cobbe, "
|
||||
"Greg Cooper, "
|
||||
"Ryan Culpepper, "
|
||||
"Carl Eastlund, "
|
||||
"Moy Easwaran, "
|
||||
"Will Farr, "
|
||||
"Matthias Felleisen, "
|
||||
"Robby Findler, "
|
||||
"Kathi Fisler, "
|
||||
"Cormac Flanagan, "
|
||||
"Matthew Flatt, "
|
||||
"Sebastian Good, "
|
||||
"Paul Graunke, "
|
||||
"Kathy Gray, "
|
||||
"Dan Grossman, "
|
||||
"Dave Gurnell, "
|
||||
"Bruce Hauman, "
|
||||
"Dave Herman, "
|
||||
"Geoffrey S. Knauth, "
|
||||
"Mark Krentel, "
|
||||
"Shriram Krishnamurthi, "
|
||||
"Mario Latendresse, "
|
||||
"Guillaume Marceau, "
|
||||
"Jacob Matthews, "
|
||||
"Jay McCarthy, "
|
||||
"Mike T. McHenry, "
|
||||
"Philippe Meunier, "
|
||||
"Scott Owens, "
|
||||
"Jamie Raymond, "
|
||||
"Grant Rettke, "
|
||||
"Paul Schlie, "
|
||||
"Dorai Sitaram, "
|
||||
"Mike Sperber, "
|
||||
"Paul Steckler, "
|
||||
"Jens Axel Søgaard, "
|
||||
"Francisco Solsona, "
|
||||
"Sam Tobin-Hochstadt, "
|
||||
"Neil W. Van Dyke, "
|
||||
"David Van Horn, "
|
||||
"Anton van Straaten, "
|
||||
"Dale Vaillancourt, "
|
||||
"Dimitris Vyzovitis, "
|
||||
"Stephanie Weirich, "
|
||||
"Noel Welsh, "
|
||||
"Adam Wick, "
|
||||
"Danny Yoo, "
|
||||
"and "
|
||||
"ChongKai Zhu."))
|
||||
#lang scheme/base
|
||||
|
||||
(define (get-translating-acks)
|
||||
(string-append
|
||||
"Thanks to "
|
||||
"ChongKai Zhu, "
|
||||
"Ian Barland, "
|
||||
"Biep Durieux, "
|
||||
"Tim Hanson, "
|
||||
"Chihiro Kuraya, "
|
||||
"Philippe Meunier, "
|
||||
"Jens Axel Søgaard, "
|
||||
"Francisco Solsona, "
|
||||
"Mike Sperber, "
|
||||
"Reini Urban, "
|
||||
"and "
|
||||
"Paolo Zoppetti "
|
||||
"for their help translating DrScheme's GUI to other languages.")))
|
||||
(provide get-general-acks
|
||||
get-translating-acks
|
||||
get-authors)
|
||||
|
||||
(define (get-authors)
|
||||
(get-general-acks))
|
||||
|
||||
(define (get-general-acks)
|
||||
(string-append
|
||||
"The following individuals contributed to the implementation"
|
||||
" and documentation of PLT Scheme: "
|
||||
"Yavuz Arkun, "
|
||||
"Ian Barland, "
|
||||
"Eli Barzilay, "
|
||||
"Gann Bierner, "
|
||||
"Filipe Cabecinhas, "
|
||||
"Richard Cleis, "
|
||||
"John Clements, "
|
||||
"Richard Cobbe, "
|
||||
"Greg Cooper, "
|
||||
"Ryan Culpepper, "
|
||||
"Carl Eastlund, "
|
||||
"Moy Easwaran, "
|
||||
"Will Farr, "
|
||||
"Matthias Felleisen, "
|
||||
"Robby Findler, "
|
||||
"Kathi Fisler, "
|
||||
"Cormac Flanagan, "
|
||||
"Matthew Flatt, "
|
||||
"Sebastian Good, "
|
||||
"Paul Graunke, "
|
||||
"Kathy Gray, "
|
||||
"Dan Grossman, "
|
||||
"Dave Gurnell, "
|
||||
"Bruce Hauman, "
|
||||
"Dave Herman, "
|
||||
"Geoffrey S. Knauth, "
|
||||
"Mark Krentel, "
|
||||
"Shriram Krishnamurthi, "
|
||||
"Mario Latendresse, "
|
||||
"Guillaume Marceau, "
|
||||
"Jacob Matthews, "
|
||||
"Jay McCarthy, "
|
||||
"Mike T. McHenry, "
|
||||
"Philippe Meunier, "
|
||||
"Scott Owens, "
|
||||
"Jamie Raymond, "
|
||||
"Grant Rettke, "
|
||||
"Paul Schlie, "
|
||||
"Dorai Sitaram, "
|
||||
"Mike Sperber, "
|
||||
"Paul Steckler, "
|
||||
"Jens Axel Søgaard, "
|
||||
"Francisco Solsona, "
|
||||
"Sam Tobin-Hochstadt, "
|
||||
"Neil W. Van Dyke, "
|
||||
"David Van Horn, "
|
||||
"Anton van Straaten, "
|
||||
"Dale Vaillancourt, "
|
||||
"Dimitris Vyzovitis, "
|
||||
"Stephanie Weirich, "
|
||||
"Noel Welsh, "
|
||||
"Adam Wick, "
|
||||
"Danny Yoo, "
|
||||
"and "
|
||||
"ChongKai Zhu."))
|
||||
|
||||
(define (get-translating-acks)
|
||||
(string-append
|
||||
"Thanks to "
|
||||
"ChongKai Zhu, "
|
||||
"Ian Barland, "
|
||||
"Biep Durieux, "
|
||||
"Tim Hanson, "
|
||||
"Chihiro Kuraya, "
|
||||
"Philippe Meunier, "
|
||||
"Jens Axel Søgaard, "
|
||||
"Francisco Solsona, "
|
||||
"Mike Sperber, "
|
||||
"Reini Urban, "
|
||||
"and "
|
||||
"Paolo Zoppetti "
|
||||
"for their help translating DrScheme's GUI to other languages."))
|
||||
|
|
|
|||
|
|
@ -1,195 +1,194 @@
|
|||
#lang scheme/base
|
||||
|
||||
(module arrow mzscheme
|
||||
(require mzlib/class
|
||||
mzlib/list
|
||||
mzlib/math
|
||||
mred)
|
||||
|
||||
(provide draw-arrow)
|
||||
|
||||
(define largest 16383)
|
||||
(define smallest -16383)
|
||||
|
||||
(define arrow-head-angle (/ pi 8))
|
||||
(define cos-arrow-head-angle (cos arrow-head-angle))
|
||||
(define sin-arrow-head-angle (sin arrow-head-angle))
|
||||
|
||||
(define arrow-head-size 8)
|
||||
(define arrow-head-size-cos-arrow-head-angle (* arrow-head-size cos-arrow-head-angle))
|
||||
(define arrow-head-size-sin-arrow-head-angle (* arrow-head-size sin-arrow-head-angle))
|
||||
|
||||
(define arrow-root-radius 2.5)
|
||||
(define arrow-root-diameter (* 2 arrow-root-radius))
|
||||
|
||||
; If alpha is the angle between the x axis and the Start->End vector:
|
||||
;
|
||||
; p2-x = end-x + arrow-head-size * cos(alpha + pi - arrow-head-angle)
|
||||
; = end-x - arrow-head-size * cos(alpha - arrow-head-angle)
|
||||
; = end-x - arrow-head-size * (cos(alpha) * cos(arrow-head-angle) + sin(alpha) * sin(arrow-head-angle))
|
||||
; = end-x - arrow-head-size-cos-arrow-head-angle * cos-alpha - arrow-head-size-sin-arrow-head-angle * sin-alpha
|
||||
; = end-x - arrow-head-size-cos-arrow-head-angle-cos-alpha - arrow-head-size-sin-arrow-head-angle-sin-alpha
|
||||
;
|
||||
; p2-y = end-y + arrow-head-size * sin(alpha + pi - arrow-head-angle)
|
||||
; = end-y - arrow-head-size * sin(alpha - arrow-head-angle)
|
||||
; = end-y - arrow-head-size * (sin(alpha) * cos(arrow-head-angle) - cos(alpha) * sin(arrow-head-angle))
|
||||
; = end-y - arrow-head-size-cos-arrow-head-angle * sin-alpha + arrow-head-size-sin-arrow-head-angle * cos-alpha
|
||||
; = end-y - arrow-head-size-cos-arrow-head-angle-sin-alpha + arrow-head-size-sin-arrow-head-angle-cos-alpha
|
||||
;
|
||||
; p3-x = end-x + arrow-head-size * cos(alpha + pi + arrow-head-angle)
|
||||
; = end-x - arrow-head-size * cos(alpha + arrow-head-angle)
|
||||
; = end-x - arrow-head-size * (cos(alpha) * cos(arrow-head-angle) - sin(alpha) * sin(arrow-head-angle))
|
||||
; = end-x - arrow-head-size-cos-arrow-head-angle * cos-alpha + arrow-head-size-sin-arrow-head-angle * sin-alpha
|
||||
; = end-x - arrow-head-size-cos-arrow-head-angle-cos-alpha + arrow-head-size-sin-arrow-head-angle-sin-alpha
|
||||
;
|
||||
; p3-y = end-y + arrow-head-size * sin(alpha + pi + arrow-head-angle)
|
||||
; = end-y - arrow-head-size * sin(alpha + arrow-head-angle)
|
||||
; = end-y - arrow-head-size * (sin(alpha) * cos(arrow-head-angle) + cos(alpha) * sin(arrow-head-angle))
|
||||
; = end-y - arrow-head-size-cos-arrow-head-angle * sin-alpha - arrow-head-size-sin-arrow-head-angle * cos-alpha
|
||||
; = end-y - arrow-head-size-cos-arrow-head-angle-sin-alpha - arrow-head-size-sin-arrow-head-angle-cos-alpha
|
||||
|
||||
; dc<%> real real real real real real -> void
|
||||
; draw one arrow
|
||||
; The reason of the "-0.5" in the definition of start-x and end-x in the let
|
||||
; right below is because, well, after numerous experiments done under carefully
|
||||
; controlled conditions by a team of independent experts, it was thought to
|
||||
; be The Right Thing for the arrows to be drawn correctly, maybe.
|
||||
(define (draw-arrow dc uncropped-pre-start-x uncropped-pre-start-y uncropped-pre-end-x uncropped-pre-end-y dx dy)
|
||||
(let ([uncropped-start-x (+ uncropped-pre-start-x dx -0.5)]
|
||||
[uncropped-start-y (+ uncropped-pre-start-y dy)]
|
||||
[uncropped-end-x (+ uncropped-pre-end-x dx -0.5)]
|
||||
[uncropped-end-y (+ uncropped-pre-end-y dy)]
|
||||
[old-smoothed (send dc get-smoothing)])
|
||||
(let*-values ([(start-x start-y) (crop-to uncropped-start-x uncropped-start-y uncropped-end-x uncropped-end-y)]
|
||||
[(end-x end-y) (crop-to uncropped-end-x uncropped-end-y uncropped-start-x uncropped-start-y)])
|
||||
(send dc set-smoothing 'aligned)
|
||||
(send dc draw-line start-x start-y end-x end-y)
|
||||
(when (and (< smallest start-x largest)
|
||||
(< smallest end-x largest))
|
||||
(send dc draw-ellipse
|
||||
(- start-x arrow-root-radius) (- start-y arrow-root-radius)
|
||||
arrow-root-diameter arrow-root-diameter))
|
||||
(when (and (< smallest end-x largest)
|
||||
(< smallest end-y largest))
|
||||
(unless (and (= start-x end-x) (= start-y end-y))
|
||||
(let* ([offset-x (- end-x start-x)]
|
||||
[offset-y (- end-y start-y)]
|
||||
[arrow-length (sqrt (+ (* offset-x offset-x) (* offset-y offset-y)))]
|
||||
[cos-alpha (/ offset-x arrow-length)]
|
||||
[sin-alpha (/ offset-y arrow-length)]
|
||||
[arrow-head-size-cos-arrow-head-angle-cos-alpha (* arrow-head-size-cos-arrow-head-angle cos-alpha)]
|
||||
[arrow-head-size-cos-arrow-head-angle-sin-alpha (* arrow-head-size-cos-arrow-head-angle sin-alpha)]
|
||||
[arrow-head-size-sin-arrow-head-angle-cos-alpha (* arrow-head-size-sin-arrow-head-angle cos-alpha)]
|
||||
[arrow-head-size-sin-arrow-head-angle-sin-alpha (* arrow-head-size-sin-arrow-head-angle sin-alpha)]
|
||||
; pt1 is the tip of the arrow, pt2 is the first point going clockwise from pt1
|
||||
[pt1 (make-object point% end-x end-y)]
|
||||
[pt2 (make-object point%
|
||||
(- end-x arrow-head-size-cos-arrow-head-angle-cos-alpha arrow-head-size-sin-arrow-head-angle-sin-alpha)
|
||||
(+ end-y (- arrow-head-size-cos-arrow-head-angle-sin-alpha) arrow-head-size-sin-arrow-head-angle-cos-alpha))]
|
||||
[pt3 (make-object point%
|
||||
(+ end-x (- arrow-head-size-cos-arrow-head-angle-cos-alpha) arrow-head-size-sin-arrow-head-angle-sin-alpha)
|
||||
(- end-y arrow-head-size-cos-arrow-head-angle-sin-alpha arrow-head-size-sin-arrow-head-angle-cos-alpha))])
|
||||
(send dc draw-polygon (list pt1 pt2 pt3)))))
|
||||
(send dc set-smoothing old-smoothed))))
|
||||
|
||||
;; crop-to : number number number number -> (values number number)
|
||||
;; returns x,y if they are in the range defined by largest and smallest
|
||||
;; otherwise returns the coordinates on the line from x,y to ox,oy
|
||||
;; that are closest to x,y and are in the range specified by
|
||||
;; largest and smallest
|
||||
(define (crop-to x y ox oy)
|
||||
(cond
|
||||
[(and (< smallest x largest) (< smallest y largest))
|
||||
(values x y)]
|
||||
[else
|
||||
(let* ([xy-pr (cons x y)]
|
||||
[left-i (find-intersection x y ox oy smallest smallest smallest largest)]
|
||||
[top-i (find-intersection x y ox oy smallest smallest largest smallest)]
|
||||
[right-i (find-intersection x y ox oy largest smallest largest largest)]
|
||||
[bottom-i (find-intersection x y ox oy smallest largest largest largest)]
|
||||
[d-top (and top-i (dist top-i xy-pr))]
|
||||
[d-bottom (and bottom-i (dist bottom-i xy-pr))]
|
||||
[d-left (and left-i (dist left-i xy-pr))]
|
||||
[d-right (and right-i (dist right-i xy-pr))])
|
||||
(cond
|
||||
[(smallest? d-top d-bottom d-left d-right)
|
||||
(values (car top-i) (cdr top-i))]
|
||||
[(smallest? d-bottom d-top d-left d-right)
|
||||
(values (car bottom-i) (cdr bottom-i))]
|
||||
[(smallest? d-left d-top d-bottom d-right)
|
||||
(values (car left-i) (cdr left-i))]
|
||||
[(smallest? d-right d-top d-bottom d-left)
|
||||
(values (car right-i) (cdr right-i))]
|
||||
[else
|
||||
;; uh oh... if this case happens, that's bad news...
|
||||
(values x y)]))]))
|
||||
|
||||
;; smallest? : (union #f number)^4 -> boolean
|
||||
;; returns #t if can is less and o1, o2, and o3
|
||||
;; if can is #f, return #f. If o1, o2, or o3 is #f, assume that can is smaller than them
|
||||
(define (smallest? can o1 o2 o3)
|
||||
(and can
|
||||
(andmap (λ (x) (< can x))
|
||||
(filter (λ (x) x)
|
||||
(list o1 o2 o3)))))
|
||||
|
||||
|
||||
;; inside? : (union #f (cons number number)) -> (union #f (cons number number))
|
||||
;; returns the original pair if the coordinates are between smallest and largest
|
||||
;; and returns #f if the pair is #f or the coordinates are outside.
|
||||
(define (inside? pr)
|
||||
(and pr
|
||||
(let ([x (car pr)]
|
||||
[y (cdr pr)])
|
||||
(if (and (< smallest x largest)
|
||||
(< smallest y largest))
|
||||
pr
|
||||
#f))))
|
||||
|
||||
;; find-intersection : (number^2)^2 -> (union (cons number number) #f)
|
||||
;; finds the intersection between the lines specified by
|
||||
;; (x1,y1) -> (x2,y2) and (x3,y3) -> (x4,y4)
|
||||
(define (find-intersection x1 y1 x2 y2 x3 y3 x4 y4)
|
||||
(cond
|
||||
[(and (= x1 x2) (= x3 x4))
|
||||
#f]
|
||||
[(and (= x1 x2) (not (= x3 x4)))
|
||||
(let* ([m2 (/ (- y3 y4) (- x3 x4))]
|
||||
[b2 (- y3 (* m2 x3))])
|
||||
(cons x1
|
||||
(+ (* m2 x1) b2)))]
|
||||
[(and (not (= x1 x2)) (= x3 x4))
|
||||
(let* ([m1 (/ (- y1 y2) (- x1 x2))]
|
||||
[b1 (- y1 (* m1 x1))])
|
||||
(cons x3
|
||||
(+ (* m1 x3) b1)))]
|
||||
[(and (not (= x1 x2)) (not (= x3 x4)))
|
||||
(let* ([m1 (/ (- y1 y2) (- x1 x2))]
|
||||
[b1 (- y1 (* m1 x1))]
|
||||
[m2 (/ (- y3 y4) (- x3 x4))]
|
||||
[b2 (- y3 (* m2 x3))])
|
||||
(if (= m1 m2)
|
||||
#f
|
||||
(let* ([x (/ (- b1 b2) (- m2 m1))]
|
||||
[y (+ (* m1 x) b1)])
|
||||
(cons x y))))]))
|
||||
|
||||
;; dist : (cons number number) (cons number number) -> number
|
||||
(define (dist p1 p2)
|
||||
(sqrt (+ (sqr (- (car p1) (car p2)))
|
||||
(sqr (- (cdr p1) (cdr p2))))))
|
||||
|
||||
;; localled defined test code.... :(
|
||||
;; use module language to run tests
|
||||
(define (tests)
|
||||
(and (equal? (find-intersection 0 1 0 10 0 2 0 20) #f)
|
||||
(equal? (find-intersection 0 1 0 10 0 0 10 10) (cons 0 0))
|
||||
(equal? (find-intersection 0 0 10 10 0 1 0 10) (cons 0 0))
|
||||
(equal? (find-intersection 0 0 3 3 2 2 4 4) #f)
|
||||
(equal? (find-intersection -3 3 3 -3 -3 -3 3 3) (cons 0 0))
|
||||
(equal? (smallest? 3 1 2 3) #f)
|
||||
(equal? (smallest? 0 1 2 3) #t)
|
||||
(equal? (smallest? 1 0 2 3) #f)
|
||||
(equal? (smallest? 1 0 #f 4) #f)
|
||||
(equal? (smallest? 1 #f #f 4) #t)
|
||||
(equal? (smallest? 1 #f #f #f) #t)
|
||||
(equal? (dist (cons 1 1) (cons 4 5)) 5))))
|
||||
(require scheme/class
|
||||
scheme/math
|
||||
scheme/gui/base)
|
||||
|
||||
(provide draw-arrow)
|
||||
|
||||
(define largest 16383)
|
||||
(define smallest -16383)
|
||||
|
||||
(define arrow-head-angle (/ pi 8))
|
||||
(define cos-arrow-head-angle (cos arrow-head-angle))
|
||||
(define sin-arrow-head-angle (sin arrow-head-angle))
|
||||
|
||||
(define arrow-head-size 8)
|
||||
(define arrow-head-size-cos-arrow-head-angle (* arrow-head-size cos-arrow-head-angle))
|
||||
(define arrow-head-size-sin-arrow-head-angle (* arrow-head-size sin-arrow-head-angle))
|
||||
|
||||
(define arrow-root-radius 2.5)
|
||||
(define arrow-root-diameter (* 2 arrow-root-radius))
|
||||
|
||||
; If alpha is the angle between the x axis and the Start->End vector:
|
||||
;
|
||||
; p2-x = end-x + arrow-head-size * cos(alpha + pi - arrow-head-angle)
|
||||
; = end-x - arrow-head-size * cos(alpha - arrow-head-angle)
|
||||
; = end-x - arrow-head-size * (cos(alpha) * cos(arrow-head-angle) + sin(alpha) * sin(arrow-head-angle))
|
||||
; = end-x - arrow-head-size-cos-arrow-head-angle * cos-alpha - arrow-head-size-sin-arrow-head-angle * sin-alpha
|
||||
; = end-x - arrow-head-size-cos-arrow-head-angle-cos-alpha - arrow-head-size-sin-arrow-head-angle-sin-alpha
|
||||
;
|
||||
; p2-y = end-y + arrow-head-size * sin(alpha + pi - arrow-head-angle)
|
||||
; = end-y - arrow-head-size * sin(alpha - arrow-head-angle)
|
||||
; = end-y - arrow-head-size * (sin(alpha) * cos(arrow-head-angle) - cos(alpha) * sin(arrow-head-angle))
|
||||
; = end-y - arrow-head-size-cos-arrow-head-angle * sin-alpha + arrow-head-size-sin-arrow-head-angle * cos-alpha
|
||||
; = end-y - arrow-head-size-cos-arrow-head-angle-sin-alpha + arrow-head-size-sin-arrow-head-angle-cos-alpha
|
||||
;
|
||||
; p3-x = end-x + arrow-head-size * cos(alpha + pi + arrow-head-angle)
|
||||
; = end-x - arrow-head-size * cos(alpha + arrow-head-angle)
|
||||
; = end-x - arrow-head-size * (cos(alpha) * cos(arrow-head-angle) - sin(alpha) * sin(arrow-head-angle))
|
||||
; = end-x - arrow-head-size-cos-arrow-head-angle * cos-alpha + arrow-head-size-sin-arrow-head-angle * sin-alpha
|
||||
; = end-x - arrow-head-size-cos-arrow-head-angle-cos-alpha + arrow-head-size-sin-arrow-head-angle-sin-alpha
|
||||
;
|
||||
; p3-y = end-y + arrow-head-size * sin(alpha + pi + arrow-head-angle)
|
||||
; = end-y - arrow-head-size * sin(alpha + arrow-head-angle)
|
||||
; = end-y - arrow-head-size * (sin(alpha) * cos(arrow-head-angle) + cos(alpha) * sin(arrow-head-angle))
|
||||
; = end-y - arrow-head-size-cos-arrow-head-angle * sin-alpha - arrow-head-size-sin-arrow-head-angle * cos-alpha
|
||||
; = end-y - arrow-head-size-cos-arrow-head-angle-sin-alpha - arrow-head-size-sin-arrow-head-angle-cos-alpha
|
||||
|
||||
; dc<%> real real real real real real -> void
|
||||
; draw one arrow
|
||||
; The reason of the "-0.5" in the definition of start-x and end-x in the let
|
||||
; right below is because, well, after numerous experiments done under carefully
|
||||
; controlled conditions by a team of independent experts, it was thought to
|
||||
; be The Right Thing for the arrows to be drawn correctly, maybe.
|
||||
(define (draw-arrow dc uncropped-pre-start-x uncropped-pre-start-y uncropped-pre-end-x uncropped-pre-end-y dx dy)
|
||||
(let ([uncropped-start-x (+ uncropped-pre-start-x dx -0.5)]
|
||||
[uncropped-start-y (+ uncropped-pre-start-y dy)]
|
||||
[uncropped-end-x (+ uncropped-pre-end-x dx -0.5)]
|
||||
[uncropped-end-y (+ uncropped-pre-end-y dy)]
|
||||
[old-smoothed (send dc get-smoothing)])
|
||||
(let*-values ([(start-x start-y) (crop-to uncropped-start-x uncropped-start-y uncropped-end-x uncropped-end-y)]
|
||||
[(end-x end-y) (crop-to uncropped-end-x uncropped-end-y uncropped-start-x uncropped-start-y)])
|
||||
(send dc set-smoothing 'aligned)
|
||||
(send dc draw-line start-x start-y end-x end-y)
|
||||
(when (and (< smallest start-x largest)
|
||||
(< smallest start-y largest))
|
||||
(send dc draw-ellipse
|
||||
(- start-x arrow-root-radius) (- start-y arrow-root-radius)
|
||||
arrow-root-diameter arrow-root-diameter))
|
||||
(when (and (< smallest end-x largest)
|
||||
(< smallest end-y largest))
|
||||
(unless (and (= start-x end-x) (= start-y end-y))
|
||||
(let* ([offset-x (- end-x start-x)]
|
||||
[offset-y (- end-y start-y)]
|
||||
[arrow-length (sqrt (+ (* offset-x offset-x) (* offset-y offset-y)))]
|
||||
[cos-alpha (/ offset-x arrow-length)]
|
||||
[sin-alpha (/ offset-y arrow-length)]
|
||||
[arrow-head-size-cos-arrow-head-angle-cos-alpha (* arrow-head-size-cos-arrow-head-angle cos-alpha)]
|
||||
[arrow-head-size-cos-arrow-head-angle-sin-alpha (* arrow-head-size-cos-arrow-head-angle sin-alpha)]
|
||||
[arrow-head-size-sin-arrow-head-angle-cos-alpha (* arrow-head-size-sin-arrow-head-angle cos-alpha)]
|
||||
[arrow-head-size-sin-arrow-head-angle-sin-alpha (* arrow-head-size-sin-arrow-head-angle sin-alpha)]
|
||||
; pt1 is the tip of the arrow, pt2 is the first point going clockwise from pt1
|
||||
[pt1 (make-object point% end-x end-y)]
|
||||
[pt2 (make-object point%
|
||||
(- end-x arrow-head-size-cos-arrow-head-angle-cos-alpha arrow-head-size-sin-arrow-head-angle-sin-alpha)
|
||||
(+ end-y (- arrow-head-size-cos-arrow-head-angle-sin-alpha) arrow-head-size-sin-arrow-head-angle-cos-alpha))]
|
||||
[pt3 (make-object point%
|
||||
(+ end-x (- arrow-head-size-cos-arrow-head-angle-cos-alpha) arrow-head-size-sin-arrow-head-angle-sin-alpha)
|
||||
(- end-y arrow-head-size-cos-arrow-head-angle-sin-alpha arrow-head-size-sin-arrow-head-angle-cos-alpha))])
|
||||
(send dc draw-polygon (list pt1 pt2 pt3)))))
|
||||
(send dc set-smoothing old-smoothed))))
|
||||
|
||||
;; crop-to : number number number number -> (values number number)
|
||||
;; returns x,y if they are in the range defined by largest and smallest
|
||||
;; otherwise returns the coordinates on the line from x,y to ox,oy
|
||||
;; that are closest to x,y and are in the range specified by
|
||||
;; largest and smallest
|
||||
(define (crop-to x y ox oy)
|
||||
(cond
|
||||
[(and (< smallest x largest) (< smallest y largest))
|
||||
(values x y)]
|
||||
[else
|
||||
(let* ([xy-pr (cons x y)]
|
||||
[left-i (find-intersection x y ox oy smallest smallest smallest largest)]
|
||||
[top-i (find-intersection x y ox oy smallest smallest largest smallest)]
|
||||
[right-i (find-intersection x y ox oy largest smallest largest largest)]
|
||||
[bottom-i (find-intersection x y ox oy smallest largest largest largest)]
|
||||
[d-top (and top-i (dist top-i xy-pr))]
|
||||
[d-bottom (and bottom-i (dist bottom-i xy-pr))]
|
||||
[d-left (and left-i (dist left-i xy-pr))]
|
||||
[d-right (and right-i (dist right-i xy-pr))])
|
||||
(cond
|
||||
[(smallest? d-top d-bottom d-left d-right)
|
||||
(values (car top-i) (cdr top-i))]
|
||||
[(smallest? d-bottom d-top d-left d-right)
|
||||
(values (car bottom-i) (cdr bottom-i))]
|
||||
[(smallest? d-left d-top d-bottom d-right)
|
||||
(values (car left-i) (cdr left-i))]
|
||||
[(smallest? d-right d-top d-bottom d-left)
|
||||
(values (car right-i) (cdr right-i))]
|
||||
[else
|
||||
;; uh oh... if this case happens, that's bad news...
|
||||
(values x y)]))]))
|
||||
|
||||
;; smallest? : (union #f number)^4 -> boolean
|
||||
;; returns #t if can is less and o1, o2, and o3
|
||||
;; if can is #f, return #f. If o1, o2, or o3 is #f, assume that can is smaller than them
|
||||
(define (smallest? can o1 o2 o3)
|
||||
(and can
|
||||
(andmap (λ (x) (< can x))
|
||||
(filter (λ (x) x)
|
||||
(list o1 o2 o3)))))
|
||||
|
||||
|
||||
;; inside? : (union #f (cons number number)) -> (union #f (cons number number))
|
||||
;; returns the original pair if the coordinates are between smallest and largest
|
||||
;; and returns #f if the pair is #f or the coordinates are outside.
|
||||
(define (inside? pr)
|
||||
(and pr
|
||||
(let ([x (car pr)]
|
||||
[y (cdr pr)])
|
||||
(if (and (< smallest x largest)
|
||||
(< smallest y largest))
|
||||
pr
|
||||
#f))))
|
||||
|
||||
;; find-intersection : (number^2)^2 -> (union (cons number number) #f)
|
||||
;; finds the intersection between the lines specified by
|
||||
;; (x1,y1) -> (x2,y2) and (x3,y3) -> (x4,y4)
|
||||
(define (find-intersection x1 y1 x2 y2 x3 y3 x4 y4)
|
||||
(cond
|
||||
[(and (= x1 x2) (= x3 x4))
|
||||
#f]
|
||||
[(and (= x1 x2) (not (= x3 x4)))
|
||||
(let* ([m2 (/ (- y3 y4) (- x3 x4))]
|
||||
[b2 (- y3 (* m2 x3))])
|
||||
(cons x1
|
||||
(+ (* m2 x1) b2)))]
|
||||
[(and (not (= x1 x2)) (= x3 x4))
|
||||
(let* ([m1 (/ (- y1 y2) (- x1 x2))]
|
||||
[b1 (- y1 (* m1 x1))])
|
||||
(cons x3
|
||||
(+ (* m1 x3) b1)))]
|
||||
[(and (not (= x1 x2)) (not (= x3 x4)))
|
||||
(let* ([m1 (/ (- y1 y2) (- x1 x2))]
|
||||
[b1 (- y1 (* m1 x1))]
|
||||
[m2 (/ (- y3 y4) (- x3 x4))]
|
||||
[b2 (- y3 (* m2 x3))])
|
||||
(if (= m1 m2)
|
||||
#f
|
||||
(let* ([x (/ (- b1 b2) (- m2 m1))]
|
||||
[y (+ (* m1 x) b1)])
|
||||
(cons x y))))]))
|
||||
|
||||
;; dist : (cons number number) (cons number number) -> number
|
||||
(define (dist p1 p2)
|
||||
(sqrt (+ (sqr (- (car p1) (car p2)))
|
||||
(sqr (- (cdr p1) (cdr p2))))))
|
||||
|
||||
;; localled defined test code.... :(
|
||||
;; use module language to run tests
|
||||
(define (tests)
|
||||
(and (equal? (find-intersection 0 1 0 10 0 2 0 20) #f)
|
||||
(equal? (find-intersection 0 1 0 10 0 0 10 10) (cons 0 0))
|
||||
(equal? (find-intersection 0 0 10 10 0 1 0 10) (cons 0 0))
|
||||
(equal? (find-intersection 0 0 3 3 2 2 4 4) #f)
|
||||
(equal? (find-intersection -3 3 3 -3 -3 -3 3 3) (cons 0 0))
|
||||
(equal? (smallest? 3 1 2 3) #f)
|
||||
(equal? (smallest? 0 1 2 3) #t)
|
||||
(equal? (smallest? 1 0 2 3) #f)
|
||||
(equal? (smallest? 1 0 #f 4) #f)
|
||||
(equal? (smallest? 1 #f #f 4) #t)
|
||||
(equal? (smallest? 1 #f #f #f) #t)
|
||||
(equal? (dist (cons 1 1) (cons 4 5)) 5)))
|
||||
|
|
|
|||
|
|
@ -1,225 +0,0 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require scheme/gui/base
|
||||
scheme/class
|
||||
framework)
|
||||
|
||||
(provide first-line-text-mixin
|
||||
first-line-text-mixin<%>)
|
||||
|
||||
(define first-line-text-mixin<%>
|
||||
(interface ()
|
||||
highlight-first-line))
|
||||
|
||||
(define dark-color (make-object color% 50 0 50))
|
||||
(define dark-wob-color (make-object color% 255 200 255))
|
||||
|
||||
(define first-line-text-mixin
|
||||
(mixin ((class->interface text%)) (first-line-text-mixin<%>)
|
||||
(inherit get-text paragraph-end-position get-admin invalidate-bitmap-cache position-location
|
||||
scroll-to local-to-global get-dc)
|
||||
(define bx (box 0))
|
||||
(define by (box 0))
|
||||
(define bw (box 0))
|
||||
|
||||
(define fancy-first-line? #f)
|
||||
|
||||
(define first-line "")
|
||||
(define end-of-first-line 0)
|
||||
(define first-line-is-lang? #f)
|
||||
|
||||
(define/private (show-first-line?)
|
||||
(and fancy-first-line? first-line-is-lang?))
|
||||
|
||||
(define/private (update-first-line)
|
||||
(set! end-of-first-line (paragraph-end-position 0))
|
||||
(set! first-line (get-text 0 end-of-first-line))
|
||||
(set! first-line-is-lang? (is-lang-line? first-line)))
|
||||
|
||||
(define/augment (after-insert start len)
|
||||
(when (<= start end-of-first-line)
|
||||
(update-first-line))
|
||||
(inner (void) after-insert start len))
|
||||
(define/augment (after-delete start len)
|
||||
(when (<= start end-of-first-line)
|
||||
(update-first-line))
|
||||
(inner (void) after-delete start len))
|
||||
|
||||
(define/private (fetch-first-line-height)
|
||||
(let-values ([(_1 h _2 _3) (send (get-dc) get-text-extent first-line (get-font))])
|
||||
h))
|
||||
|
||||
(define/override (scroll-editor-to localx localy width height refresh? bias)
|
||||
(let ([admin (get-admin)])
|
||||
(cond
|
||||
[(not admin)
|
||||
#f]
|
||||
[(show-first-line?)
|
||||
(let ([h (fetch-first-line-height)])
|
||||
(set-box! by localy)
|
||||
(local-to-global #f by)
|
||||
(cond
|
||||
[(<= (unbox by) h)
|
||||
;; the max is relevant when we're already scrolled to the top.
|
||||
(send admin scroll-to localx (max 0 (- localy h)) width height refresh? bias)]
|
||||
[else
|
||||
(send admin scroll-to localx localy width height refresh? bias)]))]
|
||||
[else
|
||||
(send admin scroll-to localx localy width height refresh? bias)])))
|
||||
|
||||
(define/public (highlight-first-line on?)
|
||||
(unless (equal? fancy-first-line? on?)
|
||||
(set! fancy-first-line? on?)
|
||||
(invalidate-bitmap-cache)
|
||||
(let ([canvas (send this get-canvas)])
|
||||
(when canvas
|
||||
(send canvas refresh)))))
|
||||
|
||||
(define/override (on-event event)
|
||||
(cond
|
||||
[(or (send event moving?)
|
||||
(send event leaving?)
|
||||
(send event entering?))
|
||||
(super on-event event)]
|
||||
[else
|
||||
(let ([y (send event get-y)]
|
||||
[h (fetch-first-line-height)]
|
||||
[admin (get-admin)])
|
||||
(unless admin (send admin get-view #f by #f #f #f))
|
||||
(cond
|
||||
[(and admin
|
||||
(< y h)
|
||||
(not (= (unbox by) 0)))
|
||||
(send admin scroll-to (send event get-x) 0 0 0 #t)
|
||||
(super on-event event)]
|
||||
[else
|
||||
(super on-event event)]))]))
|
||||
|
||||
|
||||
(define/override (on-paint before? dc left top right bottom dx dy draw-caret)
|
||||
(unless before?
|
||||
(when (show-first-line?)
|
||||
(let ([admin (get-admin)])
|
||||
(when admin
|
||||
(send admin get-view bx by bw #f #f)
|
||||
(unless (= (unbox by) 0)
|
||||
(let ([first-line (get-text 0 (paragraph-end-position 0))]
|
||||
[old-pen (send dc get-pen)]
|
||||
[old-brush (send dc get-brush)]
|
||||
[old-smoothing (send dc get-smoothing)]
|
||||
[old-α (send dc get-alpha)]
|
||||
[old-font (send dc get-font)]
|
||||
[old-text-foreground (send dc get-text-foreground)]
|
||||
[w-o-b? (preferences:get 'framework:white-on-black?)])
|
||||
(send dc set-font (get-font))
|
||||
(send dc set-smoothing 'aligned)
|
||||
(let-values ([(tw th _1 _2) (send dc get-text-extent first-line)])
|
||||
(let ([line-height (+ (unbox by) dy th 1)]
|
||||
[line-left (+ (unbox bx) dx)]
|
||||
[line-right (+ (unbox bx) dx (unbox bw))])
|
||||
|
||||
(if w-o-b?
|
||||
(send dc set-pen "white" 1 'solid)
|
||||
(send dc set-pen "black" 1 'solid))
|
||||
(send dc draw-line line-left line-height line-right line-height)
|
||||
|
||||
(when (eq? (send dc get-smoothing) 'aligned)
|
||||
(let ([start (if w-o-b? 6/10 3/10)]
|
||||
[end 0]
|
||||
[steps 10])
|
||||
(send dc set-pen
|
||||
(if w-o-b? dark-wob-color dark-color)
|
||||
1
|
||||
'solid)
|
||||
(let loop ([i steps])
|
||||
(unless (zero? i)
|
||||
(let ([alpha-value (+ start (* (- end start) (/ i steps)))])
|
||||
(send dc set-alpha alpha-value)
|
||||
(send dc draw-line
|
||||
line-left
|
||||
(+ line-height i)
|
||||
line-right
|
||||
(+ line-height i))
|
||||
(loop (- i 1))))))))
|
||||
|
||||
(send dc set-alpha 1)
|
||||
(send dc set-pen "gray" 1 'transparent)
|
||||
(send dc set-brush (if w-o-b? "black" "white") 'solid)
|
||||
(send dc draw-rectangle
|
||||
(+ (unbox bx) dx)
|
||||
(+ (unbox by) dy)
|
||||
(unbox bw)
|
||||
th)
|
||||
(send dc set-text-foreground
|
||||
(send the-color-database find-color
|
||||
(if w-o-b? "white" "black")))
|
||||
(send dc draw-text first-line (+ (unbox bx) dx) (+ (unbox by) dy)))
|
||||
|
||||
(send dc set-text-foreground old-text-foreground)
|
||||
(send dc set-font old-font)
|
||||
(send dc set-pen old-pen)
|
||||
(send dc set-brush old-brush)
|
||||
(send dc set-alpha old-α)
|
||||
(send dc set-smoothing old-smoothing)))))))
|
||||
(super on-paint before? dc left top right bottom dx dy draw-caret))
|
||||
|
||||
(inherit get-style-list)
|
||||
(define/private (get-font)
|
||||
(let* ([style-list (get-style-list)]
|
||||
[std (or (send style-list find-named-style "Standard")
|
||||
(send style-list find-named-style "Basic"))])
|
||||
(send std get-font)))
|
||||
|
||||
(super-new)))
|
||||
|
||||
;; is-lang-line? : string -> boolean
|
||||
;; given the first line in the editor, this returns #t if it is a #lang line.
|
||||
(define (is-lang-line? l)
|
||||
(let ([m (regexp-match #rx"^#(!|(lang ))([-+_/a-zA-Z0-9]+)(.|$)" l)])
|
||||
(and m
|
||||
(let ([lang-name (list-ref m 3)]
|
||||
[last-char (list-ref m 4)])
|
||||
(and (not (char=? #\/ (string-ref lang-name 0)))
|
||||
(not (char=? #\/ (string-ref lang-name (- (string-length lang-name) 1))))
|
||||
(or (string=? "" last-char)
|
||||
(char-whitespace? (string-ref last-char 0))))))))
|
||||
|
||||
;; test cases for is-lang-line?
|
||||
#;
|
||||
(list (is-lang-line? "#lang x")
|
||||
(is-lang-line? "#lang scheme")
|
||||
(is-lang-line? "#lang scheme ")
|
||||
(not (is-lang-line? "#lang schemeα"))
|
||||
(not (is-lang-line? "#lang scheme/ "))
|
||||
(not (is-lang-line? "#lang /scheme "))
|
||||
(is-lang-line? "#lang sch/eme ")
|
||||
(is-lang-line? "#lang r6rs")
|
||||
(is-lang-line? "#!r6rs")
|
||||
(is-lang-line? "#!r6rs ")
|
||||
(not (is-lang-line? "#!/bin/sh")))
|
||||
|
||||
#;
|
||||
(begin
|
||||
(define f (new frame% [label ""] [width 200] [height 200]))
|
||||
;(define t (new (editor:standard-style-list-mixin (first-line-text-mixin text%))))
|
||||
(define t
|
||||
(new
|
||||
(scheme:text-mixin
|
||||
(text:autocomplete-mixin
|
||||
(color:text-mixin
|
||||
(mode:host-text-mixin
|
||||
(values ; text:delegate-mixin
|
||||
(text:foreground-color-mixin
|
||||
(first-line-text-mixin
|
||||
text:info%)))))))))
|
||||
(require scheme/runtime-path)
|
||||
(define-runtime-path here ".")
|
||||
(send t load-file (build-path (build-path here 'up 'up "framework" "private" "text.ss")))
|
||||
#;
|
||||
(send t insert (apply string-append (map (λ (x) (build-string 100 (λ (i) (if (= i 99) #\newline x))))
|
||||
(string->list "abcdefghijklnopqrstuvwxyz"))))
|
||||
(define c (new editor-canvas% [parent f] [editor t]))
|
||||
(define b (new button% [callback (λ (c dc) (send t highlight-first-line #t))] [label "on"] [parent f]))
|
||||
(define b2 (new button% [callback (λ (c dc) (send t highlight-first-line #f))] [label "off"] [parent f]))
|
||||
(send c focus)
|
||||
(send f show #t))
|
||||
|
|
@ -53,6 +53,8 @@
|
|||
(finder:default-filters)))
|
||||
(application:current-app-name (string-constant drscheme))
|
||||
|
||||
(preferences:set-default 'drscheme:module-language-first-line-special? #t boolean?)
|
||||
|
||||
(preferences:set-default 'drscheme:defns-popup-sort-by-name? #f boolean?)
|
||||
|
||||
(preferences:set-default 'drscheme:toolbar-state
|
||||
|
|
@ -242,6 +244,11 @@
|
|||
(make-check-box 'drscheme:defs/ints-horizontal
|
||||
(string-constant interactions-beside-definitions)
|
||||
editor-panel)
|
||||
|
||||
(make-check-box 'drscheme:module-language-first-line-special?
|
||||
(string-constant ml-always-show-#lang-line)
|
||||
editor-panel)
|
||||
|
||||
;; come back to this one.
|
||||
#;
|
||||
(letrec ([hp (new horizontal-panel%
|
||||
|
|
|
|||
|
|
@ -26,7 +26,6 @@ module browser threading seems wrong.
|
|||
"drsig.ss"
|
||||
"auto-language.ss"
|
||||
"insert-large-letters-typed.ss"
|
||||
"first-line-text.ss"
|
||||
mrlib/switchable-button
|
||||
mrlib/cache-image-snip
|
||||
|
||||
|
|
@ -428,7 +427,7 @@ module browser threading seems wrong.
|
|||
(define (make-definitions-text%)
|
||||
(let ([definitions-super%
|
||||
((get-program-editor-mixin)
|
||||
(first-line-text-mixin
|
||||
(text:first-line-mixin
|
||||
(drscheme:module-language:module-language-put-file-mixin
|
||||
(scheme:text-mixin
|
||||
(color:text-mixin
|
||||
|
|
@ -671,6 +670,10 @@ module browser threading seems wrong.
|
|||
(set! needs-execution-state (string-constant needs-execute-defns-edited)))
|
||||
(inner (void) after-delete x y))
|
||||
|
||||
(define/override (is-special-first-line? l)
|
||||
(and (preferences:get 'drscheme:module-language-first-line-special?)
|
||||
(is-lang-line? l)))
|
||||
|
||||
(inherit get-filename)
|
||||
(field
|
||||
[tmp-date-string #f])
|
||||
|
|
@ -789,6 +792,32 @@ module browser threading seems wrong.
|
|||
(inherit set-max-undo-history)
|
||||
(set-max-undo-history 'forever))))
|
||||
|
||||
;; is-lang-line? : string -> boolean
|
||||
;; given the first line in the editor, this returns #t if it is a #lang line.
|
||||
(define (is-lang-line? l)
|
||||
(let ([m (regexp-match #rx"^#(!|(lang ))([-+_/a-zA-Z0-9]+)(.|$)" l)])
|
||||
(and m
|
||||
(let ([lang-name (list-ref m 3)]
|
||||
[last-char (list-ref m 4)])
|
||||
(and (not (char=? #\/ (string-ref lang-name 0)))
|
||||
(not (char=? #\/ (string-ref lang-name (- (string-length lang-name) 1))))
|
||||
(or (string=? "" last-char)
|
||||
(char-whitespace? (string-ref last-char 0))))))))
|
||||
|
||||
;; test cases for is-lang-line?
|
||||
#;
|
||||
(list (is-lang-line? "#lang x")
|
||||
(is-lang-line? "#lang scheme")
|
||||
(is-lang-line? "#lang scheme ")
|
||||
(not (is-lang-line? "#lang schemeα"))
|
||||
(not (is-lang-line? "#lang scheme/ "))
|
||||
(not (is-lang-line? "#lang /scheme "))
|
||||
(is-lang-line? "#lang sch/eme ")
|
||||
(is-lang-line? "#lang r6rs")
|
||||
(is-lang-line? "#!r6rs")
|
||||
(is-lang-line? "#!r6rs ")
|
||||
(not (is-lang-line? "#!/bin/sh")))
|
||||
|
||||
(define (get-module-language/settings)
|
||||
(let* ([module-language
|
||||
(and (preferences:get 'drscheme:switch-to-module-language-automatically?)
|
||||
|
|
|
|||
|
|
@ -223,7 +223,8 @@ If the namespace does not, they are colored the unbound color.
|
|||
get-pos/text position-location
|
||||
get-canvas last-position dc-location-to-editor-location
|
||||
find-position begin-edit-sequence end-edit-sequence
|
||||
highlight-range unhighlight-range)
|
||||
highlight-range unhighlight-range
|
||||
paragraph-end-position first-line-currently-drawn-specially?)
|
||||
|
||||
|
||||
|
||||
|
|
@ -300,19 +301,6 @@ If the namespace does not, they are colored the unbound color.
|
|||
(define cursor-location #f)
|
||||
(define cursor-text #f)
|
||||
(define cursor-eles #f)
|
||||
(define/private (find-poss text left-pos right-pos)
|
||||
(let ([xlb (box 0)]
|
||||
[ylb (box 0)]
|
||||
[xrb (box 0)]
|
||||
[yrb (box 0)])
|
||||
(send text position-location left-pos xlb ylb #t)
|
||||
(send text position-location right-pos xrb yrb #f)
|
||||
(let*-values ([(xl-off yl-off) (send text editor-location-to-dc-location (unbox xlb) (unbox ylb))]
|
||||
[(xl yl) (dc-location-to-editor-location xl-off yl-off)]
|
||||
[(xr-off yr-off) (send text editor-location-to-dc-location (unbox xrb) (unbox yrb))]
|
||||
[(xr yr) (dc-location-to-editor-location xr-off yr-off)])
|
||||
(values (/ (+ xl xr) 2)
|
||||
(/ (+ yl yr) 2)))))
|
||||
|
||||
;; find-char-box : text number number -> (values number number number number)
|
||||
;; returns the bounding box (left, top, right, bottom) for the text range.
|
||||
|
|
@ -377,7 +365,20 @@ If the namespace does not, they are colored the unbound color.
|
|||
(set-arrow-start-y! arrow start-y)
|
||||
(set-arrow-end-x! arrow end-x)
|
||||
(set-arrow-end-y! arrow end-y)))
|
||||
|
||||
|
||||
(define/private (find-poss text left-pos right-pos)
|
||||
(let ([xlb (box 0)]
|
||||
[ylb (box 0)]
|
||||
[xrb (box 0)]
|
||||
[yrb (box 0)])
|
||||
(send text position-location left-pos xlb ylb #t)
|
||||
(send text position-location right-pos xrb yrb #f)
|
||||
(let*-values ([(xl-off yl-off) (send text editor-location-to-dc-location (unbox xlb) (unbox ylb))]
|
||||
[(xl yl) (dc-location-to-editor-location xl-off yl-off)]
|
||||
[(xr-off yr-off) (send text editor-location-to-dc-location (unbox xrb) (unbox yrb))]
|
||||
[(xr yr) (dc-location-to-editor-location xr-off yr-off)])
|
||||
(values (/ (+ xl xr) 2)
|
||||
(/ (+ yl yr) 2)))))
|
||||
|
||||
;; syncheck:init-arrows : -> void
|
||||
(define/public (syncheck:init-arrows)
|
||||
|
|
@ -522,7 +523,6 @@ If the namespace does not, they are colored the unbound color.
|
|||
(loop (- n 1)))))))
|
||||
|
||||
(define/override (on-paint before dc left top right bottom dx dy draw-caret)
|
||||
(super on-paint before dc left top right bottom dx dy draw-caret)
|
||||
(when (and arrow-vectors (not before))
|
||||
(let ([draw-arrow2
|
||||
(λ (arrow)
|
||||
|
|
@ -589,7 +589,11 @@ If the namespace does not, they are colored the unbound color.
|
|||
(send dc set-pen old-pen)
|
||||
(send dc set-font old-font)
|
||||
(send dc set-text-foreground old-text-foreground)
|
||||
(send dc set-text-mode old-text-mode))))
|
||||
(send dc set-text-mode old-text-mode)))
|
||||
|
||||
;; do the drawing before calling super so that the arrows don't
|
||||
;; cross the "#lang ..." line, if it is present.
|
||||
(super on-paint before dc left top right bottom dx dy draw-caret))
|
||||
|
||||
;; for-each-tail-arrows : (tail-arrow -> void) tail-arrow -> void
|
||||
(define/private (for-each-tail-arrows f tail-arrow)
|
||||
|
|
|
|||
|
|
@ -159,6 +159,7 @@
|
|||
|
||||
(define-signature text-class^
|
||||
(basic<%>
|
||||
first-line<%>
|
||||
foreground-color<%>
|
||||
hide-caret/selection<%>
|
||||
nbsp->space<%>
|
||||
|
|
@ -192,6 +193,7 @@
|
|||
input-box%
|
||||
|
||||
basic-mixin
|
||||
first-line-mixin
|
||||
foreground-color-mixin
|
||||
hide-caret/selection-mixin
|
||||
nbsp->space-mixin
|
||||
|
|
|
|||
|
|
@ -561,6 +561,185 @@ WARNING: printf is rebound in the body of the unit to always
|
|||
(super-new)
|
||||
(set-autowrap-bitmap (initial-autowrap-bitmap))))
|
||||
|
||||
(define first-line<%>
|
||||
(interface ()
|
||||
highlight-first-line
|
||||
get-first-line-height
|
||||
first-line-currently-drawn-specially?
|
||||
is-special-first-line?))
|
||||
|
||||
(define dark-color (make-object color% 50 0 50))
|
||||
(define dark-wob-color (make-object color% 255 200 255))
|
||||
|
||||
(define first-line-mixin
|
||||
(mixin ((class->interface text%)) (first-line<%>)
|
||||
(inherit get-text paragraph-end-position get-admin invalidate-bitmap-cache position-location
|
||||
scroll-to local-to-global get-dc)
|
||||
(define bx (box 0))
|
||||
(define by (box 0))
|
||||
(define bw (box 0))
|
||||
|
||||
(define fancy-first-line? #f)
|
||||
|
||||
(define first-line "")
|
||||
(define end-of-first-line 0)
|
||||
(define first-line-is-lang? #f)
|
||||
|
||||
(define/public-final (highlight-first-line on?)
|
||||
(unless (equal? fancy-first-line? on?)
|
||||
(set! fancy-first-line? on?)
|
||||
(invalidate-bitmap-cache)
|
||||
(let ([canvas (send this get-canvas)])
|
||||
(when canvas
|
||||
(send canvas refresh)))))
|
||||
|
||||
(define/public-final (get-first-line-height)
|
||||
(let-values ([(_1 h _2 _3) (send (get-dc) get-text-extent first-line (get-font))])
|
||||
h))
|
||||
|
||||
(define/public-final (first-line-currently-drawn-specially?)
|
||||
(and (show-first-line?)
|
||||
(let ([admin (get-admin)])
|
||||
(and admin
|
||||
(begin
|
||||
(send admin get-view #f by #f #f #f)
|
||||
(not (= (unbox by) 0)))))))
|
||||
|
||||
(define/public (is-special-first-line? l) #f)
|
||||
|
||||
(define/private (show-first-line?)
|
||||
(and fancy-first-line? first-line-is-lang?))
|
||||
|
||||
(define/private (update-first-line)
|
||||
(set! end-of-first-line (paragraph-end-position 0))
|
||||
(set! first-line (get-text 0 end-of-first-line))
|
||||
(set! first-line-is-lang? (is-special-first-line? first-line)))
|
||||
|
||||
(define/augment (after-insert start len)
|
||||
(when (<= start end-of-first-line)
|
||||
(update-first-line))
|
||||
(inner (void) after-insert start len))
|
||||
(define/augment (after-delete start len)
|
||||
(when (<= start end-of-first-line)
|
||||
(update-first-line))
|
||||
(inner (void) after-delete start len))
|
||||
|
||||
(define/override (scroll-editor-to localx localy width height refresh? bias)
|
||||
(let ([admin (get-admin)])
|
||||
(cond
|
||||
[(not admin)
|
||||
#f]
|
||||
[(show-first-line?)
|
||||
(let ([h (get-first-line-height)])
|
||||
(set-box! by localy)
|
||||
(local-to-global #f by)
|
||||
(cond
|
||||
[(<= (unbox by) h)
|
||||
;; the max is relevant when we're already scrolled to the top.
|
||||
(send admin scroll-to localx (max 0 (- localy h)) width height refresh? bias)]
|
||||
[else
|
||||
(send admin scroll-to localx localy width height refresh? bias)]))]
|
||||
[else
|
||||
(send admin scroll-to localx localy width height refresh? bias)])))
|
||||
|
||||
(define/override (on-event event)
|
||||
(cond
|
||||
[(or (send event moving?)
|
||||
(send event leaving?)
|
||||
(send event entering?))
|
||||
(super on-event event)]
|
||||
[else
|
||||
(let ([y (send event get-y)]
|
||||
[h (get-first-line-height)]
|
||||
[admin (get-admin)])
|
||||
(unless admin (send admin get-view #f by #f #f #f))
|
||||
(cond
|
||||
[(and admin
|
||||
(< y h)
|
||||
(not (= (unbox by) 0)))
|
||||
(send admin scroll-to (send event get-x) 0 0 0 #t)
|
||||
(super on-event event)]
|
||||
[else
|
||||
(super on-event event)]))]))
|
||||
|
||||
|
||||
(define/override (on-paint before? dc left top right bottom dx dy draw-caret)
|
||||
(unless before?
|
||||
(when (show-first-line?)
|
||||
(let ([admin (get-admin)])
|
||||
(when admin
|
||||
(send admin get-view bx by bw #f #f)
|
||||
(unless (= (unbox by) 0)
|
||||
(let ([first-line (get-text 0 (paragraph-end-position 0))]
|
||||
[old-pen (send dc get-pen)]
|
||||
[old-brush (send dc get-brush)]
|
||||
[old-smoothing (send dc get-smoothing)]
|
||||
[old-α (send dc get-alpha)]
|
||||
[old-font (send dc get-font)]
|
||||
[old-text-foreground (send dc get-text-foreground)]
|
||||
[w-o-b? (preferences:get 'framework:white-on-black?)])
|
||||
(send dc set-font (get-font))
|
||||
(send dc set-smoothing 'aligned)
|
||||
(let-values ([(tw th _1 _2) (send dc get-text-extent first-line)])
|
||||
(let ([line-height (+ (unbox by) dy th 1)]
|
||||
[line-left (+ (unbox bx) dx)]
|
||||
[line-right (+ (unbox bx) dx (unbox bw))])
|
||||
|
||||
(if w-o-b?
|
||||
(send dc set-pen "white" 1 'solid)
|
||||
(send dc set-pen "black" 1 'solid))
|
||||
(send dc draw-line line-left line-height line-right line-height)
|
||||
|
||||
(when (eq? (send dc get-smoothing) 'aligned)
|
||||
(let ([start (if w-o-b? 6/10 3/10)]
|
||||
[end 0]
|
||||
[steps 10])
|
||||
(send dc set-pen
|
||||
(if w-o-b? dark-wob-color dark-color)
|
||||
1
|
||||
'solid)
|
||||
(let loop ([i steps])
|
||||
(unless (zero? i)
|
||||
(let ([alpha-value (+ start (* (- end start) (/ i steps)))])
|
||||
(send dc set-alpha alpha-value)
|
||||
(send dc draw-line
|
||||
line-left
|
||||
(+ line-height i)
|
||||
line-right
|
||||
(+ line-height i))
|
||||
(loop (- i 1))))))))
|
||||
|
||||
(send dc set-alpha 1)
|
||||
(send dc set-pen "gray" 1 'transparent)
|
||||
(send dc set-brush (if w-o-b? "black" "white") 'solid)
|
||||
(send dc draw-rectangle
|
||||
(+ (unbox bx) dx)
|
||||
(+ (unbox by) dy)
|
||||
(unbox bw)
|
||||
th)
|
||||
(send dc set-text-foreground
|
||||
(send the-color-database find-color
|
||||
(if w-o-b? "white" "black")))
|
||||
(send dc draw-text first-line (+ (unbox bx) dx) (+ (unbox by) dy)))
|
||||
|
||||
(send dc set-text-foreground old-text-foreground)
|
||||
(send dc set-font old-font)
|
||||
(send dc set-pen old-pen)
|
||||
(send dc set-brush old-brush)
|
||||
(send dc set-alpha old-α)
|
||||
(send dc set-smoothing old-smoothing)))))))
|
||||
(super on-paint before? dc left top right bottom dx dy draw-caret))
|
||||
|
||||
(inherit get-style-list)
|
||||
(define/private (get-font)
|
||||
(let* ([style-list (get-style-list)]
|
||||
[std (or (send style-list find-named-style "Standard")
|
||||
(send style-list find-named-style "Basic"))])
|
||||
(send std get-font)))
|
||||
|
||||
(super-new)))
|
||||
|
||||
|
||||
(define foreground-color<%>
|
||||
(interface (basic<%> editor:standard-style-list<%>)
|
||||
))
|
||||
|
|
|
|||
|
|
@ -167,9 +167,88 @@
|
|||
|
||||
}
|
||||
}
|
||||
|
||||
@definterface[text:first-line<%> (text%)]{
|
||||
|
||||
Objects implementing this interface, when
|
||||
@method[text:first-line<%> highlight-first-line]
|
||||
is invoked with @scheme[#t], always show their
|
||||
first line, even with scrolled (as long as
|
||||
@method[text:first-line<%> first-line-currently-drawn-specially?]
|
||||
returns @scheme[#t]).
|
||||
|
||||
@defmethod[#:mode public-final (highlight-first-line [on? boolean?]) void?]{
|
||||
Call this method to enable special treatment of the first line in the editor.
|
||||
}
|
||||
|
||||
@defmethod[#:mode public-final (first-line-currently-drawn-specially?) boolean?]{
|
||||
Returns @scheme[#t] if @method[text:first-line<%> is-special-first-line?]
|
||||
returned @scheme[#t] for the current first line
|
||||
and if the buffer is scrolled down so that the first
|
||||
line would not (ordinarily) be visible.
|
||||
}
|
||||
|
||||
@defmethod[#:mode public-final (get-first-line-height) number?]{
|
||||
Returns the height, in pixels, of the first line.
|
||||
}
|
||||
|
||||
@defmethod[(is-special-first-line? [line string?]) boolean?]{
|
||||
Override this method to control when the first line is always
|
||||
visible. The argument is the first line, as a string.
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
@defmixin[text:first-line-mixin (text%) (text:first-line<%>)]{
|
||||
Provides the implementation of @scheme[text:first-line<%>].
|
||||
Does so by just painting the text of the first
|
||||
line over top of what is already there and overriding
|
||||
@method[text:first-line-mixin scroll-editor-to] to patch
|
||||
up scrolling and
|
||||
@method[text:first-line-mixin on-event] to patch up
|
||||
mouse handling.
|
||||
|
||||
@defmethod[#:mode override
|
||||
(on-paint [before? any/c]
|
||||
[dc (is-a?/c dc<%>)]
|
||||
[left real?]
|
||||
[top real?]
|
||||
[right real?]
|
||||
[bottom real?]
|
||||
[dx real?]
|
||||
[dy real?]
|
||||
[draw-caret (one-of/c 'no-caret 'show-inactive-caret 'show-caret)])
|
||||
void?]{
|
||||
|
||||
Based on the various return values of the methods in @scheme[text:first-line],
|
||||
draws the first actual line of the editor over top of the first
|
||||
visible line in the editor.
|
||||
}
|
||||
|
||||
@defmethod[#:mode override
|
||||
(on-event [event (is-a?/c mouse-event%)])
|
||||
void?]{
|
||||
Clicks in the first line cause the editor to scroll to the
|
||||
actual first line.
|
||||
}
|
||||
|
||||
@defmethod[#:mode override
|
||||
(scroll-editor-to [localx real?]
|
||||
[localy real?]
|
||||
[width (and/c real? (not/c negative?))]
|
||||
[height (and/c real? (not/c negative?))]
|
||||
[refresh? any/c]
|
||||
[bias (one-of/c 'start 'end 'none)])
|
||||
void?]{
|
||||
Scrolls a little bit more, when a scroll would be requested
|
||||
that scrolls something so that it is line underneath the first line.
|
||||
}
|
||||
}
|
||||
|
||||
@definterface[text:foreground-color<%> (text:basic<%> editor:standard-style-list<%>)]{
|
||||
|
||||
}
|
||||
|
||||
@defmixin[text:foreground-color-mixin (text:basic<%> editor:standard-style-list<%>) (text:foreground-color<%>)]{
|
||||
This mixin changes the default text style to have
|
||||
the foreground color controlled by
|
||||
|
|
|
|||
|
|
@ -1263,6 +1263,8 @@ please adhere to these guidelines:
|
|||
(ml-cp-remove "Remove")
|
||||
(ml-cp-raise "Raise")
|
||||
(ml-cp-lower "Lower")
|
||||
|
||||
(ml-always-show-#lang-line "Always show #lang line in the Module language")
|
||||
|
||||
;; Profj
|
||||
(profj-java "Java")
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user