147 lines
5.5 KiB
Racket
147 lines
5.5 KiB
Racket
#lang racket
|
|
|
|
(require racket/gui)
|
|
|
|
(provide ellipsis-msg%)
|
|
|
|
(define (string-drop s n)
|
|
(let ((l (string-length s)))
|
|
(if (>= n l)
|
|
""
|
|
(substring s n))))
|
|
|
|
(define (string-drop-right s n)
|
|
(let ((l (string-length s)))
|
|
(if (>= n l)
|
|
""
|
|
(substring s 0 (- l n))
|
|
)))
|
|
|
|
(define ellipsis-msg%
|
|
(class message%
|
|
|
|
(init-field [ellipsis 'right]
|
|
[font normal-control-font])
|
|
(super-new [font font])
|
|
|
|
(define my_label "")
|
|
(define ellipsis_label "")
|
|
|
|
(define/private (ellipsize-middle w l r)
|
|
(let* ((str (string-append l "..." r))
|
|
(ext (call-with-values
|
|
(lambda () (get-window-text-extent str font))
|
|
(lambda (w h) w))))
|
|
(if (or (< w 10) (<= ext w) (string=? l "") (string=? r ""))
|
|
(string-append l "..." r)
|
|
(let* ((factor (/ w ext))
|
|
(strl (+ (string-length l) (string-length r)))
|
|
(n-strl (round (* strl factor)))
|
|
(drop (- strl n-strl))
|
|
(drop-l (inexact->exact (round (/ drop 2.0))))
|
|
(drop-r (- drop drop-l)))
|
|
(ellipsize-middle w
|
|
(string-drop-right l drop-l)
|
|
(string-drop r drop-r))))))
|
|
|
|
(define/private (ellipsize w l)
|
|
(let* ((ext (call-with-values
|
|
(lambda () (get-window-text-extent l font))
|
|
(lambda (w h) w))))
|
|
(if (or (< w 10) (<= ext w) (string=? l ""))
|
|
(if (eq? ellipsis 'right)
|
|
(string-append (string-drop-right l 3) "...")
|
|
(string-append "..." (string-drop l 3)))
|
|
(let* ((factor (/ w ext))
|
|
(strl (string-length l))
|
|
(n-strl (round (* strl factor)))
|
|
(drop (- strl n-strl)))
|
|
(when (= drop 0) (set! drop 1))
|
|
(if (eq? ellipsis 'left)
|
|
(let ((nl (string-drop l drop)))
|
|
(ellipsize w (string-drop l drop)))
|
|
(let ((nl (string-drop-right l drop)))
|
|
(ellipsize w (string-drop-right l drop))))
|
|
))))
|
|
|
|
(define/override (set-label l . resize)
|
|
(let ((rsz #f))
|
|
(unless (null? resize)
|
|
(set! rsz (car resize)))
|
|
(if (eq? rsz #t)
|
|
(super set-label l)
|
|
(let* ((width (send this get-width))
|
|
(ext (call-with-values
|
|
(lambda () (get-window-text-extent l font))
|
|
(lambda (w h) w)))
|
|
)
|
|
(set! my_label l)
|
|
(set! ellipsis_label
|
|
(if (< ext width)
|
|
l
|
|
(if (eq? ellipsis 'middle)
|
|
(let ((middle (inexact->exact
|
|
(round
|
|
(/ (string-length l) 2.0)))))
|
|
(ellipsize-middle width
|
|
(substring l 0 middle)
|
|
(substring l middle)))
|
|
(ellipsize
|
|
width
|
|
(string-append
|
|
(if (eq? ellipsis 'left) "..." "")
|
|
l
|
|
(if (eq? ellipsis 'right) "..." ""))))))
|
|
(super set-label ellipsis_label)))))
|
|
|
|
(define/override (get-label)
|
|
my_label)
|
|
))
|
|
|
|
|
|
|
|
;(require racket/gui)
|
|
;(require ellipsis-msg)
|
|
;(define win (new frame% [label "Hi there!"] [width 300]))
|
|
;
|
|
;(define hp1 (new horizontal-pane% [parent win]))
|
|
;(define btn1 (new button% [label "Longer 1"] [parent hp1]
|
|
; [callback
|
|
; (lambda (b e)
|
|
; (send lbl1 set-label
|
|
; "This is a very long text, yes a longer text than we initial put"))]
|
|
; ))
|
|
;(define lbl1 (new ellipsis-msg% [label "This is an ellipsis label"] [parent hp1]
|
|
; [ellipsis 'right] [auto-resize #t] [stretchable-width #t]))
|
|
;
|
|
;(define hp2 (new horizontal-pane% [parent win]))
|
|
;(define btn2 (new button% [label "Longer 2"] [parent hp2]
|
|
; [callback
|
|
; (lambda (b e)
|
|
; (send lbl2 set-label
|
|
; "This is a very long second text, yes a longer text than we initial put"))]
|
|
; ))
|
|
;(define lbl2 (new ellipsis-msg% [label "This is an ellipsis label"] [parent hp2]
|
|
; [ellipsis 'left] [auto-resize #t] [stretchable-width #t]))
|
|
;
|
|
;
|
|
;(define hp3 (new horizontal-pane% [parent win]))
|
|
;(define btn3 (new button% [label "Longer 3"] [parent hp3]
|
|
; [callback
|
|
; (lambda (b e)
|
|
; (send lbl3 set-label
|
|
; "This is a third very long text, yes much longer than the initial text"))]
|
|
; ))
|
|
;(define lbl3 (new ellipsis-msg% [label "This is label 3"] [parent hp3]
|
|
; [ellipsis 'middle] [auto-resize #t] [stretchable-width #t]
|
|
; [font (make-object font% 12 'default)]
|
|
; ))
|
|
;
|
|
;(define hp4 (new horizontal-pane% [parent win]))
|
|
;(define lbl4 (new message% [label "This is label 4"] [parent hp4]
|
|
; [auto-resize #t] [stretchable-width #t]
|
|
; [font (make-object font% 12 'default)]
|
|
; ))
|
|
;
|
|
;(send win show #t)
|