465 lines
18 KiB
Racket
465 lines
18 KiB
Racket
#lang racket/base
|
|
|
|
(require racket/class
|
|
racket/list
|
|
(prefix-in wx: "kernel.rkt")
|
|
"lock.rkt"
|
|
"const.rkt"
|
|
"helper.rkt"
|
|
"check.rkt"
|
|
"wx.rkt"
|
|
"wxcanvas.rkt"
|
|
"mrwindow.rkt"
|
|
"mrcontainer.rkt"
|
|
"mrtop.rkt")
|
|
|
|
(provide canvas<%>
|
|
canvas%
|
|
editor-canvas%)
|
|
|
|
(define canvas-default-size 20) ; a default size for canvases tht fits borders without losing client sizes
|
|
(define canvas-scroll-size 10)
|
|
(define canvas-control-border-extra
|
|
(case (system-type)
|
|
[(windows) 2]
|
|
[else 0]))
|
|
|
|
(define canvas<%>
|
|
(interface (subwindow<%>)
|
|
min-client-width min-client-height
|
|
on-char on-event on-paint on-tab-in
|
|
get-dc
|
|
set-canvas-background get-canvas-background
|
|
set-resize-corner
|
|
get-scaled-client-size))
|
|
|
|
(define basic-canvas%
|
|
(class* (make-subwindow% (make-window% #f (make-subarea% area%))) (canvas<%>)
|
|
(init mk-wx mismatches parent)
|
|
(define/public (on-char e) (send wx do-on-char e))
|
|
(define/public (on-event e) (send wx do-on-event e))
|
|
(define/public (on-paint) (when wx (send wx do-on-paint)))
|
|
(define/public (on-tab-in) (void))
|
|
|
|
(define min-client-width (param (lambda () wx) min-client-width))
|
|
(define min-client-height (param (lambda () wx) min-client-height))
|
|
(public min-client-width min-client-height)
|
|
|
|
(define get-dc (entry-point (lambda () (send wx get-dc))))
|
|
(public get-dc)
|
|
(define/public (make-bitmap w h)
|
|
(unless (exact-positive-integer? w)
|
|
(raise-argument-error (who->name '(method canvas% make-bitmap))
|
|
"exact-positive-integer?"
|
|
w))
|
|
(unless (exact-positive-integer? h)
|
|
(raise-argument-error (who->name '(method canvas% make-bitmap))
|
|
"exact-positive-integer?"
|
|
h))
|
|
(send wx make-compatible-bitmap w h))
|
|
|
|
(define/public (get-scaled-client-size)
|
|
(send wx get-scaled-client-size))
|
|
|
|
(define/public (suspend-flush)
|
|
(send wx begin-refresh-sequence))
|
|
(define/public (resume-flush)
|
|
(send wx end-refresh-sequence))
|
|
(define/public (flush) (send wx flush))
|
|
|
|
(define set-canvas-background
|
|
(entry-point
|
|
(lambda (c)
|
|
(unless (c . is-a? . wx:color%)
|
|
(raise-argument-error (who->name '(method canvas<%> set-canvas-background))
|
|
"(is-a?/c color%)"
|
|
c))
|
|
(unless (send wx get-canvas-background)
|
|
(raise-arguments-error (who->name '(method canvas<%> set-canvas-background))
|
|
"cannot set a transparent canvas's background color"
|
|
"given color" c))
|
|
(send wx set-canvas-background c))))
|
|
(public set-canvas-background)
|
|
(define get-canvas-background
|
|
(entry-point
|
|
(lambda ()
|
|
(send wx get-canvas-background))))
|
|
(public get-canvas-background)
|
|
|
|
(define/public (set-resize-corner on?)
|
|
(send wx set-resize-corner on?))
|
|
(define wx #f)
|
|
(as-entry
|
|
(lambda ()
|
|
(super-make-object (lambda () (set! wx (mk-wx)) wx) (lambda () wx) (lambda () wx) mismatches #f parent #f)))))
|
|
|
|
(define default-paint-cb (lambda (canvas dc) (void)))
|
|
|
|
(define canvas%
|
|
(class basic-canvas%
|
|
(init parent [style null] [paint-callback default-paint-cb] [label #f] [gl-config #f]
|
|
;; inherited inits
|
|
[enabled #t]
|
|
[vert-margin no-val]
|
|
[horiz-margin no-val]
|
|
[min-width no-val]
|
|
[min-height no-val]
|
|
[stretchable-width no-val]
|
|
[stretchable-height no-val])
|
|
(init-rest)
|
|
(define paint-cb paint-callback)
|
|
(define has-x? (and (list? style) (memq 'hscroll style)))
|
|
(define has-y? (and (list? style) (memq 'vscroll style)))
|
|
(inherit get-client-size get-dc set-label
|
|
suspend-flush resume-flush flush
|
|
get-canvas-background)
|
|
(let ([cwho '(constructor canvas)])
|
|
(check-container-parent cwho parent)
|
|
(check-style cwho #f '(border hscroll vscroll gl deleted control-border combo no-autoclear
|
|
transparent resize-corner no-focus)
|
|
style)
|
|
(check-callback cwho paint-callback)
|
|
(check-label-string/false cwho label))
|
|
(define/public (on-scroll e) (send wx do-on-scroll e))
|
|
(define/public (swap-gl-buffers)
|
|
(let ([ctx (send (send wx get-dc) get-gl-context)])
|
|
(when ctx
|
|
(send ctx swap-buffers))))
|
|
(define/public (with-gl-context
|
|
thunk
|
|
#:fail [fail (lambda ()
|
|
(error (who->name '(method canvas% with-gl-context))
|
|
"no gl context available"))])
|
|
(let ([ctx (send (send wx get-dc) get-gl-context)])
|
|
(if ctx
|
|
(send ctx call-as-current thunk)
|
|
(fail))))
|
|
(define/public (get-gl-client-size)
|
|
(send wx get-gl-client-size))
|
|
(define accept-tab-focus
|
|
(entry-point
|
|
(case-lambda
|
|
[() (send wx get-tab-focus)]
|
|
[(on?) (send wx set-tab-focus (and on? #t))])))
|
|
(public accept-tab-focus)
|
|
(define get-virtual-size
|
|
(entry-point
|
|
(lambda () (double-boxed
|
|
0 0
|
|
(lambda (x y) (send wx get-virtual-size x y))))))
|
|
(public get-virtual-size)
|
|
(define get-view-start
|
|
(entry-point
|
|
(lambda () (double-boxed
|
|
0 0
|
|
(lambda (x y) (send wx view-start x y))))))
|
|
(public get-view-start)
|
|
|
|
(define scroll
|
|
(entry-point (lambda (x y)
|
|
(when x (check-fraction '(method canvas% scroll) x))
|
|
(when y (check-fraction '(method canvas% scroll) y))
|
|
(send wx scroll (or x -1) (or y -1)))))
|
|
(public scroll)
|
|
|
|
(define/public (init-auto-scrollbars w h x y)
|
|
(when w (check-gauge-integer '(method canvas% init-auto-scrollbars) w))
|
|
(when h (check-gauge-integer '(method canvas% init-auto-scrollbars) h))
|
|
(check-fraction '(method canvas% init-auto-scrollbars) x)
|
|
(check-fraction '(method canvas% init-auto-scrollbars) y)
|
|
(let-values ([(cw ch) (get-client-size)])
|
|
(send wx set-scrollbars (if w 1 0) (if h 1 0)
|
|
(or w 0) (or h 0) 1 1
|
|
(if w (inexact->exact (floor (* x (max 0 (- w cw))))) 0)
|
|
(if h (inexact->exact (floor (* y (max 0 (- h ch))))) 0)
|
|
#t)))
|
|
|
|
(define/public (init-manual-scrollbars x-len y-len x-page y-page x-val y-val)
|
|
(let ([who '(method canvas% init-auto-scrollbars)])
|
|
(when x-len (check-gauge-integer who x-len))
|
|
(when y-len (check-gauge-integer who y-len))
|
|
(check-gauge-integer who x-page)
|
|
(check-gauge-integer who y-page)
|
|
(check-gauge-range-integer who x-val)
|
|
(check-gauge-range-integer who y-val)
|
|
(when (and x-len (< x-len x-val))
|
|
(raise-arguments-error (who->name who)
|
|
"horizontal value is larger than the horizontal range"
|
|
"value" x-val
|
|
"range" x-len))
|
|
(when (and y-len (< y-len y-val))
|
|
(raise-arguments-error (who->name who)
|
|
"vertical value is larger than the vertical range"
|
|
"value" y-val
|
|
"range" y-len)))
|
|
(send wx set-scrollbars (if x-len 1 0) (if y-len 1 0)
|
|
(or x-len 0) (or y-len 0) x-page y-page x-val y-val #f))
|
|
|
|
(define/public (show-scrollbars x-on? y-on?)
|
|
(let ([bad (lambda (which what)
|
|
(raise-arguments-error
|
|
(who->name '(method canvas% show-scrollbars))
|
|
(format
|
|
"cannot show ~a scrollbars;\n the canvas style did not include ~a"
|
|
which
|
|
what)
|
|
"canvas" this))])
|
|
(when x-on? (unless has-x? (bad "horizontal" 'hscroll)))
|
|
(when y-on? (unless has-y? (bad "vertical" 'vscroll)))
|
|
(send wx show-scrollbars x-on? y-on?)))
|
|
|
|
(define/private (check-scroll name d v must-positive?)
|
|
(unless (or (eq? d 'horizontal) (eq? d 'vertical))
|
|
(raise-argument-error (who->name `(method canvas% ,name)) "(or/c 'horizontal 'vertical)" d))
|
|
(let ([bottom (if must-positive? 1 0)])
|
|
(unless (<= bottom v GAUGE-MAX)
|
|
((check-bounded-integer bottom GAUGE-MAX #f) `(method canvas% ,name) v))))
|
|
|
|
(define get-scroll-pos (entry-point (lambda (d) (check-scroll 'get-scroll-pos d 1 #f) (send wx get-scroll-pos d))))
|
|
(define set-scroll-pos (entry-point (lambda (d v) (check-scroll 'set-scroll-pos d v #f) (send wx set-scroll-pos d v))))
|
|
(define get-scroll-range (entry-point (lambda (d) (check-scroll 'get-scroll-range d 1 #f) (send wx get-scroll-range d))))
|
|
(define set-scroll-range (entry-point (lambda (d v) (check-scroll 'set-scroll-range d v #f) (send wx set-scroll-range d v))))
|
|
(define get-scroll-page (entry-point (lambda (d) (check-scroll 'get-scroll-page d 1 #t) (send wx get-scroll-page d))))
|
|
(define set-scroll-page (entry-point (lambda (d v) (check-scroll 'set-scroll-page d v #t) (send wx set-scroll-page d v))))
|
|
(public get-scroll-pos set-scroll-pos
|
|
get-scroll-range set-scroll-range
|
|
get-scroll-page set-scroll-page)
|
|
(define/override (on-paint)
|
|
(if (eq? paint-cb default-paint-cb)
|
|
(super on-paint)
|
|
(paint-cb this (get-dc))))
|
|
(define no-clear? (memq 'no-autoclear style))
|
|
(define/public (refresh-now [do-paint (lambda (dc) (on-paint))]
|
|
#:flush? [flush? #t])
|
|
(let ([dc (get-dc)])
|
|
(dynamic-wind
|
|
(lambda ()
|
|
(suspend-flush))
|
|
(lambda ()
|
|
(unless no-clear?
|
|
(let ([bg (get-canvas-background)])
|
|
(if bg
|
|
(let ([old-bg (send dc get-background)])
|
|
(as-entry
|
|
(lambda ()
|
|
(send dc set-background bg)
|
|
(send dc clear)
|
|
(send dc set-background old-bg))))
|
|
(send dc erase))))
|
|
(do-paint dc))
|
|
(lambda ()
|
|
(resume-flush)))
|
|
(when flush? (flush))))
|
|
(define wx #f)
|
|
(super-new
|
|
[mk-wx
|
|
(lambda ()
|
|
(let ([ds (+ (cond
|
|
[(memq 'control-border style) (+ 4 canvas-control-border-extra)]
|
|
[(memq 'border style) 4]
|
|
[else 0])
|
|
(if (or has-x? has-y?)
|
|
canvas-default-size
|
|
1))])
|
|
(set! wx (make-object wx-canvas% this this
|
|
(mred->wx-container parent)
|
|
-1 -1
|
|
(+ ds (if (memq 'combo style) side-combo-width 0)) ds
|
|
style
|
|
gl-config)))
|
|
wx)]
|
|
[mismatches
|
|
(lambda ()
|
|
(let ([cwho '(constructor canvas)])
|
|
(check-container-ready cwho parent)))]
|
|
[parent parent]
|
|
[enabled enabled]
|
|
[horiz-margin horiz-margin]
|
|
[vert-margin vert-margin]
|
|
[min-width min-width]
|
|
[min-height min-height]
|
|
[stretchable-width stretchable-width]
|
|
[stretchable-height stretchable-height])
|
|
(when label
|
|
(set-label label))
|
|
(send parent after-new-child this)))
|
|
|
|
(define editor-canvas%
|
|
(class basic-canvas%
|
|
(init parent [editor #f] [style null] [scrolls-per-page 100] [label #f]
|
|
[wheel-step no-val] [line-count no-val]
|
|
[horizontal-inset 5] [vertical-inset 5]
|
|
;; inherited inits
|
|
[enabled #t]
|
|
[vert-margin no-val]
|
|
[horiz-margin no-val]
|
|
[min-width no-val]
|
|
[min-height no-val]
|
|
[stretchable-width no-val]
|
|
[stretchable-height no-val])
|
|
(init-rest)
|
|
(let ([cwho '(constructor editor-canvas)])
|
|
(check-container-parent cwho parent)
|
|
(check-instance cwho internal-editor<%> "text% or pasteboard%" #t editor)
|
|
(check-style cwho #f '(hide-vscroll hide-hscroll no-vscroll no-hscroll auto-vscroll auto-hscroll
|
|
deleted control-border combo transparent no-border resize-corner
|
|
no-focus)
|
|
style)
|
|
(check-gauge-integer cwho scrolls-per-page)
|
|
(check-label-string/false cwho label)
|
|
(unless (eq? wheel-step no-val)
|
|
(check-wheel-step cwho wheel-step))
|
|
(unless (or (not line-count) (eq? line-count no-val))
|
|
((check-bounded-integer 1 1000 #t) cwho line-count))
|
|
(unless (eq? horizontal-inset 5)
|
|
(check-margin-integer cwho horizontal-inset))
|
|
(unless (eq? vertical-inset 5)
|
|
(check-margin-integer cwho vertical-inset)))
|
|
(inherit set-label)
|
|
(define force-focus? #f)
|
|
(define scroll-to-last? #f)
|
|
(define scroll-bottom? #f)
|
|
(define/public (call-as-primary-owner f) (send wx call-as-primary-owner f))
|
|
(define allow-scroll-to-last
|
|
(entry-point
|
|
(case-lambda
|
|
[() scroll-to-last?]
|
|
[(on?) (set! scroll-to-last? (and on? #t))
|
|
(send wx allow-scroll-to-last on?)])))
|
|
(public allow-scroll-to-last)
|
|
(define scroll-with-bottom-base
|
|
(entry-point
|
|
(case-lambda
|
|
[() scroll-bottom?]
|
|
[(on?) (set! scroll-bottom? (and on? #t))
|
|
(send wx scroll-with-bottom-base on?)])))
|
|
(public scroll-with-bottom-base)
|
|
(define lazy-refresh
|
|
(entry-point
|
|
(case-lambda
|
|
[() (send wx get-lazy-refresh)]
|
|
[(on?) (send wx set-lazy-refresh on?)])))
|
|
(public lazy-refresh)
|
|
(define force-display-focus
|
|
(entry-point
|
|
(case-lambda
|
|
[() force-focus?]
|
|
[(on?) (set! force-focus? (and on? #t))
|
|
(send wx force-display-focus on?)])))
|
|
(public force-display-focus)
|
|
|
|
(define accept-tab-focus
|
|
(entry-point
|
|
(case-lambda
|
|
[() (send wx get-tab-focus)]
|
|
[(on?) (send wx set-tab-focus (and on? #t))])))
|
|
(public accept-tab-focus)
|
|
(define allow-tab-exit
|
|
(entry-point
|
|
(case-lambda
|
|
[() (send wx is-tabable?)]
|
|
[(on?) (send wx set-tabable (and on? #t))])))
|
|
(public allow-tab-exit)
|
|
|
|
(define set-line-count
|
|
(entry-point
|
|
(lambda (n)
|
|
((check-bounded-integer 1 1000 #t) '(method editor-canvas% set-line-count) n)
|
|
(send wx set-line-count n))))
|
|
(public set-line-count)
|
|
(define get-line-count
|
|
(entry-point
|
|
(lambda ()
|
|
(send wx get-line-count))))
|
|
(public get-line-count)
|
|
|
|
(define scroll-to
|
|
(case-lambda
|
|
[(x y w h refresh?) (send wx scroll-to x y w h refresh?)]
|
|
[(x y w h refresh? bias) (send wx scroll-to x y w h refresh? bias)]))
|
|
(public scroll-to)
|
|
|
|
(define get-editor (entry-point (lambda () (send wx get-editor))))
|
|
(define set-editor (entry-point
|
|
(case-lambda
|
|
[(m) (send wx set-editor m)]
|
|
[(m upd?) (send wx set-editor m upd?)])))
|
|
(public get-editor set-editor)
|
|
(define ws
|
|
(case-lambda
|
|
[() (let ([v (send wx get-wheel-step)])
|
|
(if (zero? v) #f v))]
|
|
[(wheel-step)
|
|
(check-wheel-step '(method editor-canvas% wheel-step) wheel-step)
|
|
(send wx set-wheel-step (or wheel-step 0))]))
|
|
(public [ws wheel-step])
|
|
(define vi
|
|
(entry-point
|
|
(case-lambda
|
|
[() (send wx get-y-margin)]
|
|
[(m)
|
|
(check-margin-integer '(method editor-canvas% vertical-inset) m)
|
|
(as-exit (lambda () (send wx set-y-margin m)))])))
|
|
(public [vi vertical-inset])
|
|
(define hi
|
|
(entry-point
|
|
(case-lambda
|
|
[() (send wx get-x-margin)]
|
|
[(m)
|
|
(check-margin-integer '(method editor-canvas% horizontal-inset) m)
|
|
(as-exit (lambda () (send wx set-x-margin m)))])))
|
|
(public [hi horizontal-inset])
|
|
(define wx #f)
|
|
(super-new
|
|
[mk-wx
|
|
(lambda ()
|
|
(let* ([no-h? (or (memq 'no-vscroll style)
|
|
(memq 'hide-vscroll style))]
|
|
[no-v? (or (memq 'no-hscroll style)
|
|
(memq 'hide-hscroll style))]
|
|
[get-ds (lambda (no-this? no-other?)
|
|
(+ (if (memq 'control-border style)
|
|
canvas-control-border-extra
|
|
0)
|
|
(cond
|
|
[(and no-this? no-other?) 14]
|
|
[no-this? canvas-default-size]
|
|
[else (+ canvas-scroll-size canvas-default-size)])))])
|
|
(set! wx (make-object wx-editor-canvas% this this
|
|
(mred->wx-container parent) -1 -1
|
|
(+ (get-ds no-h? no-v?) (if (memq 'combo style) side-combo-width 0))
|
|
(get-ds no-v? no-h?)
|
|
#f
|
|
(append
|
|
(if (memq 'no-border style)
|
|
null
|
|
'(border))
|
|
(remq 'no-border style))
|
|
scrolls-per-page #f))
|
|
wx))]
|
|
[mismatches
|
|
(lambda ()
|
|
(let ([cwho '(constructor editor-canvas)])
|
|
(check-container-ready cwho parent)))]
|
|
[parent parent]
|
|
[enabled enabled]
|
|
[horiz-margin horiz-margin]
|
|
[vert-margin vert-margin]
|
|
[min-width min-width]
|
|
[min-height min-height]
|
|
[stretchable-width stretchable-width]
|
|
[stretchable-height stretchable-height])
|
|
(unless (eq? wheel-step no-val)
|
|
(ws wheel-step))
|
|
(when label
|
|
(set-label label))
|
|
(when editor
|
|
(set-editor editor))
|
|
(send parent after-new-child this)
|
|
(unless (or (not line-count) (eq? line-count no-val))
|
|
(set-line-count line-count))
|
|
(unless (or (eq? vertical-inset 5))
|
|
(vi vertical-inset))
|
|
(unless (or (eq? horizontal-inset 5))
|
|
(hi horizontal-inset))))
|