├── README.md ├── cairo ├── examples │ ├── samples-arc.sps │ ├── urman-tutorial-fill.sps │ ├── urman-tutorial-mask.sps │ ├── urman-tutorial-paint.sps │ ├── urman-tutorial-path-close.sps │ ├── urman-tutorial-set-source-gradient.sps │ ├── urman-tutorial-set-source-rgba.sps │ ├── urman-tutorial-show-text.sps │ ├── urman-tutorial-stroke.sps │ ├── urman-tutorial-text-extents.sps │ ├── urman-tutorial-tips-ellipse.sps │ ├── urman-tutorial-tips-font.sps │ └── urman-tutorial-tips-letter.sps ├── is-font-extents.sls ├── is-text-extents.sls └── with-cairo.sls ├── cfdg ├── core.sls ├── examples │ ├── chiaroscuro.sps │ ├── game1-turn6.sps │ └── spirales.sps ├── hsva-to-rgba.sls ├── hsva.sls ├── rgba.sls ├── rule.sls └── util.sls ├── cons-wm ├── README └── cons-wm.sps └── xlib ├── compat.sls ├── ffi.sls ├── keysym.sls ├── util.sls └── util ├── x-fetch-name.sls ├── x-get-geometry.sls └── x-query-tree.sls /README.md: -------------------------------------------------------------------------------- 1 | 2 | # Setup # 3 | 4 | $ cd ~/scheme # Where '~/scheme' is the path to your Scheme libraries 5 | $ git clone git://github.com/dharmatech/dharmalab.git 6 | $ git clone git://github.com/dharmatech/surfage.git 7 | $ git clone git://github.com/dharmatech/psilab.git 8 | -------------------------------------------------------------------------------- /cairo/examples/samples-arc.sps: -------------------------------------------------------------------------------- 1 | 2 | (import (rnrs) 3 | (ypsilon cairo) 4 | (psilab cairo with-cairo)) 5 | 6 | (define M_PI (* 2 (asin 1))) 7 | 8 | (let ((surface (cairo_image_surface_create CAIRO_FORMAT_ARGB32 256 256))) 9 | 10 | (let ((cr (cairo_create surface))) 11 | 12 | (with-cairo cr 13 | 14 | (let ((xc 128.0) 15 | (yc 128.0) 16 | (radius 100.0) 17 | (angle1 (* 45.0 (/ M_PI 180.0))) 18 | (angle2 (* 180.0 (/ M_PI 180.0)))) 19 | 20 | (cairo_set_line_width cr 10.0) 21 | (cairo_arc cr xc yc radius angle1 angle2) 22 | (cairo_stroke cr) 23 | 24 | (cairo_set_source_rgba cr 1 0.2 0.2 0.6) 25 | (cairo_set_line_width cr 6.0) 26 | 27 | (cairo_arc cr xc yc 10.0 0 (* 2 M_PI)) 28 | (cairo_fill cr) 29 | 30 | (cairo_arc cr xc yc radius angle1 angle1) 31 | (cairo_line_to cr xc yc) 32 | (cairo_arc cr xc yc radius angle2 angle2) 33 | (cairo_line_to cr xc yc) 34 | (cairo_stroke cr) 35 | 36 | (destroy)))) 37 | 38 | (cairo_surface_write_to_png surface "sample-arc.png") 39 | 40 | (cairo_surface_destroy surface)) -------------------------------------------------------------------------------- /cairo/examples/urman-tutorial-fill.sps: -------------------------------------------------------------------------------- 1 | 2 | (import (rnrs) 3 | (ypsilon cairo) 4 | (psilab cairo with-cairo)) 5 | 6 | (let ((surface (cairo_image_surface_create CAIRO_FORMAT_ARGB32 120 120))) 7 | 8 | (let ((cr (cairo_create surface))) 9 | 10 | (with-cairo cr 11 | 12 | (scale 120 120) 13 | 14 | (set_source_rgb 0 0 0) 15 | (rectangle 0.25 0.25 0.5 0.5) 16 | (fill) 17 | 18 | (destroy))) 19 | 20 | (cairo_surface_write_to_png surface "fill.png") 21 | (cairo_surface_destroy surface)) -------------------------------------------------------------------------------- /cairo/examples/urman-tutorial-mask.sps: -------------------------------------------------------------------------------- 1 | 2 | (import (rnrs) 3 | (ypsilon cairo) 4 | (psilab cairo with-cairo)) 5 | 6 | (let ((surface (cairo_image_surface_create CAIRO_FORMAT_ARGB32 120 120))) 7 | 8 | (let ((cr (cairo_create surface))) 9 | 10 | (with-cairo cr 11 | 12 | (scale 120 120) 13 | 14 | (let ((linpat (cairo_pattern_create_linear 0 0 1 1))) 15 | 16 | (cairo_pattern_add_color_stop_rgb linpat 0 0 0.3 0.8) 17 | (cairo_pattern_add_color_stop_rgb linpat 1 0 0.8 0.3) 18 | 19 | (set_source linpat) 20 | 21 | (cairo_pattern_destroy linpat)) 22 | 23 | (let ((radpat (cairo_pattern_create_radial 0.5 0.5 0.25 0.5 0.5 0.75))) 24 | 25 | (cairo_pattern_add_color_stop_rgba radpat 0 0 0 0 1) 26 | (cairo_pattern_add_color_stop_rgba radpat 0.5 0 0 0 0) 27 | 28 | (mask radpat) 29 | 30 | (cairo_pattern_destroy radpat)) 31 | 32 | (cairo_destroy cr))) 33 | 34 | (cairo_surface_write_to_png surface "mask.png") 35 | 36 | (cairo_surface_destroy surface)) 37 | -------------------------------------------------------------------------------- /cairo/examples/urman-tutorial-paint.sps: -------------------------------------------------------------------------------- 1 | 2 | (import (rnrs) 3 | (ypsilon cairo) 4 | (psilab cairo with-cairo)) 5 | 6 | (let ((surface (cairo_image_surface_create CAIRO_FORMAT_ARGB32 120 120))) 7 | 8 | (let ((cr (cairo_create surface))) 9 | 10 | (with-cairo cr 11 | 12 | (scale 120 120) 13 | 14 | (set_source_rgb 0 0 0) 15 | 16 | (paint_with_alpha 0.5) 17 | 18 | (destroy))) 19 | 20 | (cairo_surface_write_to_png surface "paint.png") 21 | 22 | (cairo_surface_destroy surface)) -------------------------------------------------------------------------------- /cairo/examples/urman-tutorial-path-close.sps: -------------------------------------------------------------------------------- 1 | 2 | (import (rnrs) 3 | (ypsilon cairo) 4 | (psilab cairo with-cairo)) 5 | 6 | (define M_PI (* 2 (asin 1))) 7 | 8 | (let ((surface (cairo_image_surface_create CAIRO_FORMAT_ARGB32 120 120))) 9 | 10 | (let ((cr (cairo_create surface))) 11 | 12 | (with-cairo cr 13 | 14 | (scale 120 120) 15 | 16 | (set_line_width 0.1) 17 | 18 | (set_source_rgb 0 0 0) 19 | 20 | (move_to 0.25 0.25) 21 | 22 | (line_to 0.5 0.375) 23 | 24 | (rel_line_to 0.25 -0.125) 25 | 26 | (arc 0.5 0.5 (* 0.25 (sqrt 2)) (* -0.25 M_PI) (* 0.25 M_PI)) 27 | 28 | (rel_curve_to -0.25 -0.125 -0.25 0.125 -0.5 0) 29 | 30 | (close_path) 31 | 32 | (stroke) 33 | 34 | (destroy))) 35 | 36 | (cairo_surface_write_to_png surface "path-close.png") 37 | 38 | (cairo_surface_destroy surface)) -------------------------------------------------------------------------------- /cairo/examples/urman-tutorial-set-source-gradient.sps: -------------------------------------------------------------------------------- 1 | 2 | (import (rnrs) 3 | (surfage s42 eager-comprehensions) 4 | (ypsilon cairo) 5 | (psilab cairo with-cairo)) 6 | 7 | (let ((surface (cairo_image_surface_create CAIRO_FORMAT_ARGB32 120 120))) 8 | 9 | (let ((cr (cairo_create surface))) 10 | 11 | (with-cairo cr 12 | 13 | (scale 120 120) 14 | 15 | (let ((radpat (cairo_pattern_create_radial 0.25 0.25 0.1 0.5 0.5 0.5))) 16 | 17 | (cairo_pattern_add_color_stop_rgb radpat 0 1.0 0.8 0.8) 18 | (cairo_pattern_add_color_stop_rgb radpat 1 0.9 0.0 0.0) 19 | 20 | (do-ec (: i 1 10) 21 | (do-ec (: j 1 10) 22 | (rectangle (- (/ i 10.0) 0.04) 23 | (- (/ j 10.0) 0.04) 24 | 0.08 25 | 0.08))) 26 | 27 | (set_source radpat) 28 | (fill)) 29 | 30 | (let ((linpat (cairo_pattern_create_linear 0.25 0.35 0.75 0.65))) 31 | 32 | (cairo_pattern_add_color_stop_rgba linpat 0.00 1 1 1 0) 33 | (cairo_pattern_add_color_stop_rgba linpat 0.25 0 1 0 0.5) 34 | (cairo_pattern_add_color_stop_rgba linpat 0.50 1 1 1 0) 35 | (cairo_pattern_add_color_stop_rgba linpat 0.75 0 0 1 0.5) 36 | (cairo_pattern_add_color_stop_rgba linpat 1.00 1 1 1 0) 37 | 38 | (rectangle 0.0 0.0 1 1) 39 | (set_source linpat) 40 | (fill)) 41 | 42 | (destroy))) 43 | 44 | (cairo_surface_write_to_png surface "set-source-gradient.png") 45 | 46 | (cairo_surface_destroy surface)) -------------------------------------------------------------------------------- /cairo/examples/urman-tutorial-set-source-rgba.sps: -------------------------------------------------------------------------------- 1 | 2 | (import (rnrs) 3 | (ypsilon cairo) 4 | (psilab cairo with-cairo)) 5 | 6 | (let ((surface (cairo_image_surface_create CAIRO_FORMAT_ARGB32 120 120))) 7 | 8 | (let ((cr (cairo_create surface))) 9 | 10 | (with-cairo cr 11 | 12 | (scale 120 120) 13 | 14 | (set_source_rgb 0 0 0) 15 | 16 | (move_to 0 0) 17 | (line_to 1 1) 18 | (move_to 1 0) 19 | (line_to 0 1) 20 | (set_line_width 0.2) 21 | (stroke) 22 | 23 | (rectangle 0 0 0.5 0.5) 24 | (set_source_rgba 1 0 0 0.80) 25 | (fill) 26 | 27 | (rectangle 0 0.5 0.5 0.5) 28 | (set_source_rgba 0 1 0 0.60) 29 | (fill) 30 | 31 | (rectangle 0.5 0 0.5 0.5) 32 | (set_source_rgba 0 0 1 0.40) 33 | (fill) 34 | 35 | (destroy)) 36 | 37 | (cairo_surface_write_to_png surface "set-source-rgba.png") 38 | 39 | (cairo_surface_destroy surface))) -------------------------------------------------------------------------------- /cairo/examples/urman-tutorial-show-text.sps: -------------------------------------------------------------------------------- 1 | 2 | (import (rnrs) 3 | (ypsilon cairo) 4 | (psilab cairo with-cairo)) 5 | 6 | (define-c-struct-methods cairo_text_extents_t) 7 | 8 | (let ((surface (cairo_image_surface_create CAIRO_FORMAT_ARGB32 120 120))) 9 | 10 | (let ((cr (cairo_create surface))) 11 | 12 | (with-cairo cr 13 | 14 | (scale 120 120) 15 | 16 | (set_source_rgb 0 0 0) 17 | 18 | (select_font_face "Georgia" 19 | CAIRO_FONT_SLANT_NORMAL 20 | CAIRO_FONT_WEIGHT_BOLD) 21 | 22 | (set_font_size 1.2) 23 | 24 | (let ((te (make-cairo_text_extents_t))) 25 | 26 | (text_extents "a" te) 27 | 28 | (move_to (- 0.5 29 | (/ (cairo_text_extents_t-width te) 2) 30 | (cairo_text_extents_t-x_bearing te)) 31 | (- 0.5 32 | (/ (cairo_text_extents_t-height te) 2) 33 | (cairo_text_extents_t-y_bearing te)))) 34 | 35 | (show_text "a") 36 | 37 | (destroy))) 38 | 39 | (cairo_surface_write_to_png surface "show-text.png") 40 | (cairo_surface_destroy surface)) 41 | -------------------------------------------------------------------------------- /cairo/examples/urman-tutorial-stroke.sps: -------------------------------------------------------------------------------- 1 | 2 | (import (rnrs) 3 | (ypsilon cairo) 4 | (psilab cairo with-cairo)) 5 | 6 | (let ((surface (cairo_image_surface_create CAIRO_FORMAT_ARGB32 120 120))) 7 | 8 | (let ((cr (cairo_create surface))) 9 | 10 | (with-cairo cr 11 | 12 | (scale 120 120) 13 | 14 | (set_line_width 0.1) 15 | 16 | (set_source_rgb 0 0 0) 17 | 18 | (rectangle 0.25 0.25 0.5 0.5) 19 | 20 | (stroke) 21 | 22 | (destroy))) 23 | 24 | (cairo_surface_write_to_png surface "stroke.png") 25 | 26 | (cairo_surface_destroy surface)) -------------------------------------------------------------------------------- /cairo/examples/urman-tutorial-text-extents.sps: -------------------------------------------------------------------------------- 1 | 2 | (import (rnrs) 3 | (ypsilon c-types) 4 | (ypsilon cairo) 5 | (psilab cairo with-cairo) 6 | (psilab cairo is-font-extents) 7 | (psilab cairo is-text-extents)) 8 | 9 | (define M_PI (* 2 (asin 1))) 10 | 11 | (define-c-struct-methods cairo_font_extents_t) 12 | (define-c-struct-methods cairo_text_extents_t) 13 | 14 | (let ((surface (cairo_image_surface_create CAIRO_FORMAT_ARGB32 240 240))) 15 | 16 | (let ((cr (cairo_create surface))) 17 | 18 | (with-cairo cr 19 | 20 | (let ((text "joy") 21 | (fe (make-cairo_font_extents_t)) 22 | (te (make-cairo_text_extents_t))) 23 | 24 | (is-font-extents fe) 25 | (is-text-extents te) 26 | 27 | (scale 240 240) 28 | 29 | (set_font_size 0.5) 30 | 31 | (set_source_rgb 0 0 0) 32 | 33 | (select_font_face "Georgia" 34 | CAIRO_FONT_SLANT_NORMAL 35 | CAIRO_FONT_WEIGHT_BOLD) 36 | 37 | (font_extents fe) 38 | 39 | (let ((px (let ((ux (make-c-double 1)) 40 | (uy (make-c-double 1))) 41 | (device_to_user_distance ux uy) 42 | (max (bytevector-c-double-ref ux 0) 43 | (bytevector-c-double-ref uy 0))))) 44 | 45 | (font_extents fe) 46 | 47 | (text_extents text te) 48 | 49 | (let ((x (- 0.5 te.x_bearing (/ te.width 2))) 50 | (y (+ (- 0.5 fe.descent) 51 | (/ fe.height 2)))) 52 | 53 | (set_line_width (* 4 px)) 54 | 55 | (let ((dash-length (make-c-double (* 9 px)))) 56 | (set_dash dash-length 1 0)) 57 | 58 | (set_source_rgba 0 0.6 0 0.5) 59 | 60 | (move_to (+ x te.x_bearing) y) 61 | (rel_line_to te.width 0) 62 | 63 | (move_to (+ x te.x_bearing) 64 | (+ y fe.descent)) 65 | (rel_line_to te.width 0) 66 | 67 | (move_to (+ x te.x_bearing) (- y fe.ascent)) 68 | (rel_line_to (cairo_text_extents_t-width te) 0) 69 | 70 | (move_to (+ x te.x_bearing) (- y fe.height)) 71 | (rel_line_to te.width 0) 72 | 73 | (stroke) 74 | 75 | (set_source_rgba 0 0 0.75 0.5) 76 | 77 | (set_line_width px) 78 | 79 | (let ((dash-length (make-c-double (* 3 px)))) 80 | (set_dash dash-length 1 0)) 81 | 82 | (rectangle (+ x te.x_bearing) 83 | (+ y te.y_bearing) 84 | te.width 85 | te.height) 86 | 87 | (stroke) 88 | 89 | 90 | (move_to x y) 91 | (set_source_rgb 0 0 0) 92 | (show_text text) 93 | 94 | 95 | (set_dash 0 0 0) 96 | (set_line_width (* 2 px)) 97 | (set_source_rgba 0 0 0.75 0.5) 98 | (move_to x y) 99 | (rel_line_to te.x_bearing te.y_bearing) 100 | (stroke) 101 | 102 | (set_source_rgba 0 0 0.75 0.5) 103 | (arc (+ x te.x_advance) 104 | (+ y te.y_advance) 105 | (* 5 px) 106 | 0 107 | (* 2 M_PI)) 108 | (fill) 109 | 110 | (arc x y (* 5 px) 0 (* 2 M_PI)) 111 | (set_source_rgba 0.75 0 0 0.5) 112 | (fill) 113 | 114 | (stroke) 115 | 116 | (destroy)))))) 117 | 118 | (cairo_surface_write_to_png surface "text-extents.png") 119 | 120 | (cairo_surface_destroy surface)) -------------------------------------------------------------------------------- /cairo/examples/urman-tutorial-tips-ellipse.sps: -------------------------------------------------------------------------------- 1 | 2 | (import (rnrs) 3 | (ypsilon cairo) 4 | (psilab cairo with-cairo)) 5 | 6 | (define M_PI (* 2 (asin 1))) 7 | 8 | (let ((surface (cairo_image_surface_create CAIRO_FORMAT_ARGB32 120 120))) 9 | 10 | (let ((cr (cairo_create surface))) 11 | 12 | (with-cairo cr 13 | 14 | (scale 120 120) 15 | 16 | (set_line_width 0.1) 17 | 18 | (save) 19 | (scale 0.5 1) 20 | (arc 0.5 0.5 0.40 0 (* 2 M_PI)) 21 | (stroke) 22 | 23 | (translate 1 0) 24 | (arc 0.5 0.5 0.40 0 (* 2 M_PI)) 25 | (restore) 26 | (stroke) 27 | 28 | (destroy))) 29 | 30 | (cairo_surface_write_to_png surface "tips-ellipse.png") 31 | 32 | (cairo_surface_destroy surface)) 33 | -------------------------------------------------------------------------------- /cairo/examples/urman-tutorial-tips-font.sps: -------------------------------------------------------------------------------- 1 | 2 | (import (rnrs) 3 | (surfage s42 eager-comprehensions) 4 | (ypsilon cairo) 5 | (psilab cairo with-cairo) 6 | (psilab cairo is-font-extents) 7 | (psilab cairo is-text-extents)) 8 | 9 | (define-c-struct-methods cairo_font_extents_t) 10 | (define-c-struct-methods cairo_text_extents_t) 11 | 12 | (let ((surface (cairo_image_surface_create CAIRO_FORMAT_ARGB32 780 30))) 13 | 14 | (let ((cr (cairo_create surface))) 15 | 16 | (with-cairo cr 17 | 18 | (scale 30 30) 19 | (set_font_size 0.8) 20 | 21 | (set_source_rgb 0.0 0.0 0.0) 22 | (select_font_face "Georgia" 23 | CAIRO_FONT_SLANT_NORMAL 24 | CAIRO_FONT_WEIGHT_BOLD) 25 | 26 | (let ((alphabet "AbCdEfGhIjKlMnOpQrStUvWxYz") 27 | (fe (make-cairo_font_extents_t)) 28 | (te (make-cairo_text_extents_t))) 29 | (is-font-extents fe) 30 | (is-text-extents te) 31 | (font_extents fe) 32 | (do-ec (: i (string-length alphabet)) 33 | (let ((letter (substring alphabet i (+ i 1)))) 34 | (text_extents letter te) 35 | (move_to (- (+ i 0.5) 36 | te.x_bearing 37 | (/ te.width 2)) 38 | (+ (- 0.5 fe.descent) 39 | (/ fe.height 2))) 40 | (show_text letter)))) 41 | 42 | (destroy))) 43 | 44 | (cairo_surface_write_to_png surface "tips-font.png") 45 | 46 | (cairo_surface_destroy surface)) 47 | -------------------------------------------------------------------------------- /cairo/examples/urman-tutorial-tips-letter.sps: -------------------------------------------------------------------------------- 1 | 2 | (import (rnrs) 3 | (surfage s42 eager-comprehensions) 4 | (ypsilon cairo) 5 | (psilab cairo with-cairo) 6 | (psilab cairo is-text-extents)) 7 | 8 | (define-c-struct-methods cairo_text_extents_t) 9 | 10 | (let ((surface (cairo_image_surface_create CAIRO_FORMAT_ARGB32 780 30))) 11 | 12 | (let ((cr (cairo_create surface))) 13 | 14 | (with-cairo cr 15 | 16 | (scale 30 30) 17 | 18 | (set_font_size 0.8) 19 | 20 | (set_source_rgb 0.0 0.0 0.0) 21 | (select_font_face "Georgia" 22 | CAIRO_FONT_SLANT_NORMAL 23 | CAIRO_FONT_WEIGHT_BOLD) 24 | 25 | (let ((alphabet "AbCdEfGhIjKlMnOpQrStUvWxYz") 26 | (te (make-cairo_text_extents_t))) 27 | (is-text-extents te) 28 | (do-ec (: i (string-length alphabet)) 29 | (let ((letter (substring alphabet i (+ i 1)))) 30 | (text_extents letter te) 31 | (move_to (- (+ i 0.5) 32 | te.x_bearing 33 | (/ te.width 2)) 34 | (- 0.5 te.y_bearing (/ te.height 2))) 35 | (show_text letter)))) 36 | 37 | (destroy))) 38 | 39 | (cairo_surface_write_to_png surface "tips-letter.png") 40 | 41 | (cairo_surface_destroy surface)) 42 | -------------------------------------------------------------------------------- /cairo/is-font-extents.sls: -------------------------------------------------------------------------------- 1 | 2 | (library (psilab cairo is-font-extents) 3 | 4 | (export is-font-extents) 5 | 6 | (import (rnrs) 7 | (dharmalab misc gen-id) 8 | (ypsilon cairo)) 9 | 10 | (define-c-struct-methods cairo_font_extents_t) 11 | 12 | (define-syntax is-font-extents 13 | (lambda (stx) 14 | (syntax-case stx () 15 | ((is-font-extents var) 16 | (with-syntax ((var.ascent (gen-id #'var #'var ".ascent")) 17 | (var.descent (gen-id #'var #'var ".descent")) 18 | (var.height (gen-id #'var #'var ".height")) 19 | (var.max_x_advance (gen-id #'var #'var ".max_x_advance")) 20 | (var.max_y_advance (gen-id #'var #'var ".max_y_advance"))) 21 | 22 | #'(begin 23 | 24 | (define-syntax var.ascent (identifier-syntax (cairo_font_extents_t-ascent var))) 25 | (define-syntax var.descent (identifier-syntax (cairo_font_extents_t-descent var))) 26 | (define-syntax var.height (identifier-syntax (cairo_font_extents_t-height var))) 27 | (define-syntax var.max_x_advance (identifier-syntax (cairo_font_extents_t-max_x_advance var))) 28 | (define-syntax var.max_y_advance (identifier-syntax (cairo_font_extents_t-max_y_advance var))) 29 | 30 | (define (var.ascent! val) (cairo_font_extents_t-ascent-set! var val)) 31 | (define (var.descent! val) (cairo_font_extents_t-descent-set! var val)) 32 | (define (var.height! val) (cairo_font_extents_t-height-set! var val)) 33 | (define (var.max_x_advance! val) (cairo_font_extents_t-max_x_advance-set! var val)) 34 | (define (var.max_y_advance! val) (cairo_font_extents_t-max_y_advance-set! var val))))))))) 35 | -------------------------------------------------------------------------------- /cairo/is-text-extents.sls: -------------------------------------------------------------------------------- 1 | 2 | (library (psilab cairo is-text-extents) 3 | 4 | (export is-text-extents) 5 | 6 | (import (rnrs) 7 | (dharmalab misc gen-id) 8 | (ypsilon cairo)) 9 | 10 | (define-c-struct-methods cairo_text_extents_t) 11 | 12 | (define-syntax is-text-extents 13 | (lambda (stx) 14 | (syntax-case stx () 15 | ((is-text-extents var) 16 | (with-syntax ((var.x_bearing (gen-id #'var #'var ".x_bearing")) 17 | (var.y_bearing (gen-id #'var #'var ".y_bearing")) 18 | (var.width (gen-id #'var #'var ".width")) 19 | (var.height (gen-id #'var #'var ".height")) 20 | (var.x_advance (gen-id #'var #'var ".x_advance")) 21 | (var.y_advance (gen-id #'var #'var ".y_advance"))) 22 | 23 | #'(begin 24 | 25 | (define-syntax var.x_bearing (identifier-syntax (cairo_text_extents_t-x_bearing var))) 26 | (define-syntax var.y_bearing (identifier-syntax (cairo_text_extents_t-y_bearing var))) 27 | (define-syntax var.width (identifier-syntax (cairo_text_extents_t-width var))) 28 | (define-syntax var.height (identifier-syntax (cairo_text_extents_t-height var))) 29 | (define-syntax var.x_advance (identifier-syntax (cairo_text_extents_t-x_advance var))) 30 | (define-syntax var.y_advance (identifier-syntax (cairo_text_extents_t-y_advance var))) 31 | 32 | (define (var.x_bearing! val) (cairo_text_extents_t-x_bearing-set! var val)) 33 | (define (var.y_bearing! val) (cairo_text_extents_t-y_bearing-set! var val)) 34 | (define (var.width! val) (cairo_text_extents_t-width-set! var val)) 35 | (define (var.height! val) (cairo_text_extents_t-height-set! var val)) 36 | (define (var.x_advance! val) (cairo_text_extents_t-x_advance-set! var val)) 37 | (define (var.y_advance! val) (cairo_text_extents_t-y_advance-set! var val))))))))) 38 | -------------------------------------------------------------------------------- /cairo/with-cairo.sls: -------------------------------------------------------------------------------- 1 | 2 | (library (psilab cairo with-cairo) 3 | 4 | (export with-cairo) 5 | 6 | (import (rnrs) 7 | (dharmalab misc gen-id) 8 | (ypsilon cairo)) 9 | 10 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 11 | 12 | (define-syntax define-with-cairo-syntax 13 | (lambda (stx) 14 | (syntax-case stx () 15 | ( (define-with-cairo-syntax var method param ...) 16 | (with-syntax ( (cairo_method (gen-id #'var "cairo_" #'method)) 17 | (met (gen-id #'var #'method)) ) 18 | #'(begin 19 | (define (met param ...) (cairo_method var param ...)) 20 | )) )))) 21 | 22 | (define-syntax with-cairo 23 | (lambda (stx) 24 | (syntax-case stx () 25 | ( (with-cairo var expr ...) 26 | #'(begin 27 | 28 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 29 | ;; cairo drawing context 30 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 31 | 32 | ;; cairo_create (cairo_surface_t *target); 33 | 34 | (define-with-cairo-syntax var reference) 35 | (define-with-cairo-syntax var destroy) 36 | (define-with-cairo-syntax var status) 37 | (define-with-cairo-syntax var save) 38 | (define-with-cairo-syntax var restore) 39 | (define-with-cairo-syntax var get_target) 40 | (define-with-cairo-syntax var push_group) 41 | (define-with-cairo-syntax var push_group_with_content content) 42 | (define-with-cairo-syntax var pop_group) 43 | (define-with-cairo-syntax var pop_group_to_source) 44 | (define-with-cairo-syntax var get_group_target) 45 | 46 | (define-with-cairo-syntax var set_source_rgb red green blue) 47 | (define-with-cairo-syntax var set_source_rgba red green blue alpha) 48 | (define-with-cairo-syntax var set_source source) 49 | (define-with-cairo-syntax var set_source_surface surface x y) 50 | 51 | (define-with-cairo-syntax var get_source) 52 | ;; antialias_t 53 | (define-with-cairo-syntax var set_antialias antialias) 54 | (define-with-cairo-syntax var get_antialias) 55 | 56 | (define-with-cairo-syntax var set_dash dashes num_dashes offset) 57 | 58 | (define-with-cairo-syntax var get_dash_count) 59 | 60 | (define-with-cairo-syntax var get_dash dashes offset) 61 | 62 | ;; fill_rule_t 63 | 64 | (define-with-cairo-syntax var set_fill_rule fill_rule) 65 | (define-with-cairo-syntax var get_fill_rule) 66 | 67 | ;; line_cap_t 68 | 69 | (define-with-cairo-syntax var set_line_cap line_cap) 70 | (define-with-cairo-syntax var get_line_cap) 71 | 72 | ;; line_join_t 73 | 74 | (define-with-cairo-syntax var set_line_join line_join) 75 | (define-with-cairo-syntax var get_line_join) 76 | (define-with-cairo-syntax var set_line_width width) 77 | (define-with-cairo-syntax var get_line_width) 78 | 79 | (define-with-cairo-syntax var set_miter_limit limit) 80 | 81 | (define-with-cairo-syntax var get_miter_limit) 82 | 83 | ;; operator_t 84 | 85 | (define-with-cairo-syntax var set_operator op) 86 | 87 | (define-with-cairo-syntax var get_operator) 88 | 89 | (define-with-cairo-syntax var set_tolerance tolerance) 90 | 91 | (define-with-cairo-syntax var get_tolerance) 92 | (define-with-cairo-syntax var clip) 93 | (define-with-cairo-syntax var clip_preserve) 94 | 95 | (define-with-cairo-syntax var clip_extents x1 y1 x2 y2) 96 | 97 | (define-with-cairo-syntax var reset_clip) 98 | 99 | ;; rectangle_t 100 | ;; rectangle_list_t 101 | 102 | (define-with-cairo-syntax var rectangle_list_destroy rectangle_list) 103 | (define-with-cairo-syntax var copy_clip_rectangle_list ) 104 | 105 | (define-with-cairo-syntax var fill) 106 | (define-with-cairo-syntax var fill_preserve) 107 | 108 | (define-with-cairo-syntax var fill_extents x1 y1 x2 y2) 109 | 110 | (define-with-cairo-syntax var in_fill x y) 111 | (define-with-cairo-syntax var mask pattern) 112 | (define-with-cairo-syntax var mask_surface surface surface_x surface_y) 113 | 114 | (define-with-cairo-syntax var paint) 115 | (define-with-cairo-syntax var paint_with_alpha alpha) 116 | (define-with-cairo-syntax var stroke) 117 | (define-with-cairo-syntax var stroke_preserve) 118 | (define-with-cairo-syntax var stroke_extents x1 y1 x2 y2) 119 | (define-with-cairo-syntax var in_stroke x y) 120 | 121 | (define-with-cairo-syntax var copy_page) 122 | (define-with-cairo-syntax var show_page) 123 | (define-with-cairo-syntax var get_reference_count) 124 | 125 | (define-with-cairo-syntax var set_user_data key user_data destroy) 126 | (define-with-cairo-syntax var get_user_data key) 127 | 128 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 129 | ;; paths 130 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 131 | 132 | ;; cairo_path_t 133 | ;; cairo_path_data_t 134 | ;; cairo_path_data_type_t 135 | 136 | (define-with-cairo-syntax var copy_path ) 137 | (define-with-cairo-syntax var copy_path_flat ) 138 | (define-with-cairo-syntax var path_destroy path) 139 | (define-with-cairo-syntax var append_path path) 140 | (define-with-cairo-syntax var has_current_point ) 141 | (define-with-cairo-syntax var get_current_point x y) 142 | (define-with-cairo-syntax var new_path ) 143 | (define-with-cairo-syntax var new_sub_path ) 144 | (define-with-cairo-syntax var close_path ) 145 | (define-with-cairo-syntax var arc xc yc radius angle1 angle2) 146 | (define-with-cairo-syntax var arc_negative xc yc radius angle1 angle2) 147 | (define-with-cairo-syntax var curve_to x1 y1 x2 y2 x3 y3) 148 | (define-with-cairo-syntax var line_to x y) 149 | (define-with-cairo-syntax var move_to x y) 150 | (define-with-cairo-syntax var rectangle x y width height) 151 | (define-with-cairo-syntax var glyph_path glyphs num_glyphs) 152 | (define-with-cairo-syntax var text_path utf8) 153 | (define-with-cairo-syntax var rel_curve_to dx1 dy1 dx2 dy2 dx3 dy3) 154 | (define-with-cairo-syntax var rel_line_to dx dy) 155 | (define-with-cairo-syntax var rel_move_to dx dy) 156 | (define-with-cairo-syntax var path_extents x1 y1 x2 y2) 157 | 158 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 159 | ;; transformations 160 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 161 | 162 | (define-with-cairo-syntax var translate tx ty) 163 | (define-with-cairo-syntax var scale sx sy) 164 | (define-with-cairo-syntax var rotate angle) 165 | (define-with-cairo-syntax var transform matrix) 166 | (define-with-cairo-syntax var set_matrix matrix) 167 | (define-with-cairo-syntax var get_matrix matrix) 168 | (define-with-cairo-syntax var identity_matrix) 169 | (define-with-cairo-syntax var user_to_device x y) 170 | (define-with-cairo-syntax var user_to_device_distance dx dy) 171 | (define-with-cairo-syntax var device_to_user x y) 172 | (define-with-cairo-syntax var device_to_user_distance dx dy) 173 | 174 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 175 | ;; text 176 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 177 | 178 | (define-with-cairo-syntax var select_font_face family slant weight) 179 | (define-with-cairo-syntax var set_font_size size) 180 | (define-with-cairo-syntax var set_font_matrix matrix) 181 | (define-with-cairo-syntax var get_font_matrix matrix) 182 | (define-with-cairo-syntax var set_font_options options) 183 | (define-with-cairo-syntax var get_font_options options) 184 | (define-with-cairo-syntax var set_font_face font_face) 185 | (define-with-cairo-syntax var get_font_face ) 186 | (define-with-cairo-syntax var set_scaled_font scaled_font) 187 | (define-with-cairo-syntax var get_scaled_font ) 188 | (define-with-cairo-syntax var show_text utf8) 189 | (define-with-cairo-syntax var show_glyphs glyphs num_glyphs) 190 | (define-with-cairo-syntax var show_text_glyphs utf8 utf8_len glyphs num_glyphs clusters num_clusters cluster_flags) 191 | (define-with-cairo-syntax var font_extents extents) 192 | (define-with-cairo-syntax var text_extents utf8 extents) 193 | (define-with-cairo-syntax var glyph_extents glyphs num_glyphs extents) 194 | 195 | expr 196 | ...)))))) -------------------------------------------------------------------------------- /cfdg/core.sls: -------------------------------------------------------------------------------- 1 | 2 | (library (psilab cfdg core) 3 | 4 | (export save 5 | restore 6 | 7 | scale 8 | rotate 9 | x 10 | y 11 | flip 12 | 13 | hue 14 | saturation 15 | brightness 16 | alpha 17 | 18 | circle 19 | square 20 | triangle 21 | 22 | continue? 23 | 24 | bounds 25 | viewport 26 | 27 | background 28 | start-shape 29 | 30 | init-cfdg 31 | ) 32 | 33 | (import (rnrs) 34 | (surfage s27 random-bits) 35 | (ypsilon ffi) 36 | (ypsilon cairo) 37 | (dharmalab misc random-weighted) 38 | (psilab cfdg util) 39 | (psilab cfdg rgba) 40 | (psilab cfdg hsva) 41 | (psilab cfdg hsva-to-rgba)) 42 | 43 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 44 | 45 | (define cr #f) 46 | (define surface #f) 47 | 48 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 49 | ;; read-command-line 50 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 51 | 52 | (define area-width 400) 53 | (define area-height 400) 54 | 55 | (define out-file "out.png") 56 | 57 | (define (read-command-line) 58 | 59 | (let ((result (member "--width" (command-line)))) 60 | (when result 61 | (set! area-width (string->number (list-ref result 1))))) 62 | 63 | (let ((result (member "--height" (command-line)))) 64 | (when result 65 | (set! area-height (string->number (list-ref result 1))))) 66 | 67 | (let ((result (member "--out-file" (command-line)))) 68 | (when result 69 | (set! out-file (list-ref result 1))))) 70 | 71 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 72 | ;; hue saturation brightness alpha 73 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 74 | 75 | (define color #f) 76 | 77 | (define (adjust num) 78 | (lambda (val) 79 | (if (> num 0.0) 80 | (+ val (* (- 1.0 val) num)) 81 | (+ val (* val num))))) 82 | 83 | (define (hue num) 84 | (hsva-hue-set! color (mod (+ (hsva-hue color) num) 360))) 85 | 86 | (define (saturation num) 87 | (hsva-saturation-set! color ((adjust num) (hsva-saturation color)))) 88 | 89 | (define (brightness num) 90 | (hsva-value-set! color ((adjust num) (hsva-value color)))) 91 | 92 | (define (alpha num) 93 | (hsva-alpha-set! color ((adjust num) (hsva-alpha color)))) 94 | 95 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 96 | 97 | (define (cairo-set-source-rgba cr val) 98 | (cairo_set_source_rgba cr 99 | (rgba-red val) 100 | (rgba-green val) 101 | (rgba-blue val) 102 | (rgba-alpha val))) 103 | 104 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 105 | ;; bounds viewport 106 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 107 | 108 | (define (bounds x-low x-high y-low y-high) 109 | 110 | (let ((width (- x-high x-low)) 111 | (height (- y-high y-low))) 112 | 113 | (cairo_scale cr area-width area-height) 114 | 115 | (cairo_scale cr 1 -1) 116 | 117 | (cairo_scale cr (/ 1.0 width) (/ 1.0 height)) 118 | 119 | ;; (cairo_translate cr x-high (- y-high)) 120 | 121 | (cairo_translate cr (- x-low) (- y-high)) 122 | 123 | )) 124 | 125 | (define (viewport x-low width y-low height) 126 | (bounds x-low (+ x-low width) y-low (+ y-low height))) 127 | 128 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 129 | ;; save restore 130 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 131 | 132 | (define (clone-hsva obj) 133 | (make-hsva (hsva-hue obj) 134 | (hsva-saturation obj) 135 | (hsva-value obj) 136 | (hsva-alpha obj))) 137 | 138 | (define color-stack '()) 139 | 140 | (define (save) 141 | (set! color-stack (cons (clone-hsva color) color-stack)) 142 | (cairo_save cr)) 143 | 144 | (define (restore) 145 | (cairo_restore cr) 146 | (set! color (car color-stack)) 147 | (set! color-stack (cdr color-stack)) 148 | (cairo-set-source-rgba cr (hsva->rgba color))) 149 | 150 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 151 | ;; rotate scale size x y 152 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 153 | 154 | (define (rotate n) 155 | (cairo_rotate cr (radians n))) 156 | 157 | (define scale 158 | (case-lambda 159 | ((n) (cairo_scale cr n n)) 160 | ((x y) (cairo_scale cr x y)))) 161 | 162 | (define size scale) 163 | 164 | (define (x val) (cairo_translate cr val 0.0)) 165 | (define (y val) (cairo_translate cr 0.0 val)) 166 | 167 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 168 | 169 | (define-c-struct-methods cairo_matrix_t) 170 | 171 | (define flip 172 | 173 | (let ((ctm (make-cairo_matrix_t)) 174 | (A (make-cairo_matrix_t)) 175 | (B (make-cairo_matrix_t))) 176 | 177 | (lambda (angle) 178 | 179 | (let ((angle (radians angle))) 180 | 181 | (cairo_get_matrix cr ctm) 182 | (cairo_get_matrix cr A) 183 | 184 | (cairo_matrix_init B 185 | (cos (* 2 angle)) (sin (* 2 angle)) 186 | (sin (* 2 angle)) (- (cos (* 2 angle))) 187 | 0.0 188 | 0.0) 189 | 190 | ;; (cairo_matrix_multiply ctm A B) 191 | 192 | (cairo_matrix_multiply ctm B A) 193 | 194 | (cairo_set_matrix cr ctm))))) 195 | 196 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 197 | 198 | (define (circle) 199 | (cairo-set-source-rgba cr (hsva->rgba color)) 200 | (cairo_arc cr 0.0 0.0 0.5 0 (* 2 pi)) 201 | (cairo_fill cr)) 202 | 203 | (define (square) 204 | (cairo-set-source-rgba cr (hsva->rgba color)) 205 | (cairo_rectangle cr -0.5 -0.5 1.0 1.0) 206 | (cairo_fill cr)) 207 | 208 | (define (triangle) 209 | (cairo-set-source-rgba cr (hsva->rgba color)) 210 | (cairo_move_to cr 0.0 0.577) 211 | (cairo_line_to cr 0.5 -0.289) 212 | (cairo_line_to cr -0.5 -0.289) 213 | (cairo_fill cr)) 214 | 215 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 216 | ;; continue? 217 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 218 | 219 | (define (norm v) 220 | (sqrt (+ (sq (vector-ref v 0)) 221 | (sq (vector-ref v 1))))) 222 | 223 | (define (unit-distance) 224 | 225 | (let ((x (make-c-double 1.0)) 226 | (y (make-c-double 0.0))) 227 | 228 | (cairo_user_to_device_distance cr x y) 229 | 230 | (norm (vector (c-double-ref x) 231 | (c-double-ref y))))) 232 | 233 | ;; (define (continue?) 234 | ;; (> (unit-distance) 1.0)) 235 | 236 | (define (continue?) 237 | (> (unit-distance) 0.5)) 238 | 239 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 240 | 241 | (define-syntax background 242 | (syntax-rules () 243 | ((background adjustment ...) 244 | (begin 245 | (set! color (make-hsva 0.0 0.0 1.0 1.0)) 246 | adjustment 247 | ... 248 | (cairo-set-source-rgba cr (hsva->rgba color)) 249 | 250 | ;; (cairo_rectangle cr 251 | ;; x-min 252 | ;; y-min 253 | ;; (- x-max x-min) 254 | ;; (- y-max y-min)) 255 | 256 | (cairo_rectangle cr 0 0 area-width area-height) 257 | 258 | (cairo_fill cr))))) 259 | 260 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 261 | 262 | (define (start-shape proc) 263 | 264 | (set! color (make-hsva 0.0 0.0 0.0 1.0)) 265 | 266 | (cairo-set-source-rgba cr (hsva->rgba color)) 267 | 268 | (proc) 269 | 270 | (cairo_destroy cr) 271 | 272 | (cairo_surface_write_to_png surface out-file) 273 | 274 | (cairo_surface_destroy surface)) 275 | 276 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 277 | 278 | (define (init-cairo) 279 | (set! surface (cairo_image_surface_create CAIRO_FORMAT_ARGB32 280 | area-width 281 | area-height)) 282 | (set! cr (cairo_create surface))) 283 | 284 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 285 | 286 | (define (init-cfdg) 287 | (random-source-randomize! default-random-source) 288 | (read-command-line) 289 | (init-cairo))) -------------------------------------------------------------------------------- /cfdg/examples/chiaroscuro.sps: -------------------------------------------------------------------------------- 1 | 2 | ;; Based on the original at: 3 | ;; 4 | ;; http://www.contextfreeart.org/gallery/view.php?id=541 5 | ;; 6 | ;; Ported to Scheme by Ed Cavazos 7 | 8 | (import (psilab cfdg core) 9 | (psilab cfdg rule)) 10 | 11 | (rule black 12 | (60 (circle (scale 0.6)) 13 | (black (x 0.1) 14 | (rotate 5) 15 | (scale 0.99) 16 | (brightness -0.01) 17 | (alpha -0.01))) 18 | 19 | (1 (white) (black))) 20 | 21 | (rule white 22 | (60 (circle (scale 0.6)) 23 | (white (x 0.1) 24 | (rotate -5) 25 | (scale 0.99) 26 | (brightness 0.01) 27 | (alpha -0.01))) 28 | 29 | (1 (black) (white))) 30 | 31 | (rule chiaroscuro 32 | (1 (black (brightness 0.5)))) 33 | 34 | (init-cfdg) 35 | 36 | (background (brightness -0.5)) 37 | 38 | (bounds -3 3 -2 4) 39 | 40 | (start-shape chiaroscuro) 41 | 42 | -------------------------------------------------------------------------------- /cfdg/examples/game1-turn6.sps: -------------------------------------------------------------------------------- 1 | 2 | ;; Based on the original at: 3 | ;; 4 | ;; http://www.contextfreeart.org/gallery/view.php?id=118 5 | ;; 6 | ;; Ported to Scheme by Ed Cavazos 7 | 8 | (import (psilab cfdg core) 9 | (psilab cfdg rule)) 10 | 11 | (rule start 12 | (1 (spiral) 13 | (spiral (rotate 120)) 14 | (spiral (rotate 240)))) 15 | 16 | (rule spiral 17 | 18 | (1 (f-squares) 19 | (f-triangles (x 0.5) (y 0.5) (rotate 45)) 20 | (spiral (y 1.0) (rotate 25) (scale 0.9))) 21 | 22 | (0.022 (start (flip 90) (hue 50)))) 23 | 24 | (rule f-squares 25 | (1 (square (x 0.1) (y 0.1) 26 | (alpha -0.33) (hue 250) (saturation 0.70) (brightness 0.80)) 27 | (square (hue 220) (saturation 0.90) (brightness 0.33)) 28 | (square (scale 0.9) (hue 220) (saturation 0.25) (brightness 1.00)) 29 | (f-squares (scale 0.8) (rotate 5)))) 30 | 31 | (rule f-triangles 32 | (1 (triangle (x 0.1) (y 0.1) 33 | (alpha -0.33) (hue 20) (saturation 0.7) (brightness 0.80)) 34 | (triangle (hue 10) (saturation 0.9) (brightness 0.33)) 35 | (triangle (scale 0.9) (hue 10) (saturation 0.5) (brightness 1.00)) 36 | (f-triangles (scale 0.8) (rotate 5)))) 37 | 38 | (init-cfdg) 39 | 40 | (background (hue 66) (saturation 0.4) (brightness 0.5)) 41 | 42 | (bounds -5 5 -5 5) 43 | 44 | (start-shape start) 45 | 46 | -------------------------------------------------------------------------------- /cfdg/examples/spirales.sps: -------------------------------------------------------------------------------- 1 | 2 | ;; Based on the original at: 3 | ;; 4 | ;; http://www.contextfreeart.org/gallery/view.php?id=1182 5 | ;; 6 | ;; Ported to Scheme by Ed Cavazos 7 | 8 | (import (psilab cfdg core) 9 | (psilab cfdg rule)) 10 | 11 | (rule line 12 | (1 (a1 (x -3) (flip 90)) 13 | (a1 (rotate 120) (x -3) (flip 90)) 14 | (a1 (rotate 240) (x -3) (flip 90)))) 15 | 16 | (rule a1 17 | (1 (a1 (scale 0.95) (x 2) (rotate 12) 18 | (brightness 0.5) (hue 10) (saturation 1.0)) 19 | (chunk))) 20 | 21 | (rule chunk 22 | (1 (circle) 23 | (line (alpha -0.3) (scale 0.3) (flip 60)))) 24 | 25 | (init-cfdg) 26 | 27 | (background (brightness -1)) 28 | 29 | (bounds -20 20 -20 20) 30 | 31 | (start-shape line) 32 | -------------------------------------------------------------------------------- /cfdg/hsva-to-rgba.sls: -------------------------------------------------------------------------------- 1 | 2 | (library (psilab cfdg hsva-to-rgba) 3 | 4 | (export hsva->rgba) 5 | 6 | (import (rnrs) 7 | (psilab cfdg rgba) 8 | (psilab cfdg hsva)) 9 | 10 | (define (hsva->rgba color) 11 | 12 | (let ((hue (inexact (hsva-hue color))) 13 | (saturation (inexact (hsva-saturation color))) 14 | (value (inexact (hsva-value color))) 15 | (alpha (inexact (hsva-alpha color)))) 16 | 17 | (let ((Hi (mod (floor (/ hue 60.0)) 6.0))) 18 | 19 | (let ((f (- (/ hue 60.0) Hi)) 20 | (p (* (- 1.0 saturation) value))) 21 | 22 | (let ((q (* (- 1.0 (* f saturation)) value)) 23 | (t (* (- 1.0 (* (- 1.0 f) saturation)) value))) 24 | 25 | (case (exact Hi) 26 | ((0) (make-rgba value t p alpha)) 27 | ((1) (make-rgba q value p alpha)) 28 | ((2) (make-rgba p value t alpha)) 29 | ((3) (make-rgba p q value alpha)) 30 | ((4) (make-rgba t p value alpha)) 31 | ((5) (make-rgba value p q alpha))))))))) -------------------------------------------------------------------------------- /cfdg/hsva.sls: -------------------------------------------------------------------------------- 1 | 2 | (library (psilab cfdg hsva) 3 | 4 | (export make-hsva 5 | hsva? 6 | hsva-hue 7 | hsva-saturation 8 | hsva-value 9 | hsva-alpha 10 | hsva-hue-set! 11 | hsva-saturation-set! 12 | hsva-value-set! 13 | hsva-alpha-set!) 14 | 15 | (import (rnrs)) 16 | 17 | (define-record-type hsva 18 | (fields (mutable hue) 19 | (mutable saturation) 20 | (mutable value) 21 | (mutable alpha)))) -------------------------------------------------------------------------------- /cfdg/rgba.sls: -------------------------------------------------------------------------------- 1 | 2 | (library (psilab cfdg rgba) 3 | 4 | (export make-rgba 5 | rgba? 6 | rgba-red 7 | rgba-green 8 | rgba-blue 9 | rgba-alpha 10 | rgba-red-set! 11 | rgba-green-set! 12 | rgba-blue-set! 13 | rgba-alpha-set!) 14 | 15 | (import (rnrs)) 16 | 17 | (define-record-type rgba 18 | (fields (mutable red) 19 | (mutable green) 20 | (mutable blue) 21 | (mutable alpha)))) -------------------------------------------------------------------------------- /cfdg/rule.sls: -------------------------------------------------------------------------------- 1 | 2 | (library (psilab cfdg rule) 3 | 4 | (export rule) 5 | 6 | (import (rnrs) 7 | (dharmalab misc random-weighted) 8 | (psilab cfdg core)) 9 | 10 | (define-syntax rule 11 | 12 | (syntax-rules () 13 | 14 | ( (rule name 15 | (weight (shape adjustment ...) ...) 16 | ...) 17 | 18 | (define name 19 | 20 | (let ((selector (random-weighted-selector (list weight ...))) 21 | 22 | (procedures (vector (lambda () 23 | (let () 24 | (save) adjustment ... (shape) (restore)) 25 | ...) 26 | ...))) 27 | 28 | (lambda () 29 | (when (continue?) 30 | (let ((proc (vector-ref procedures (selector)))) 31 | (proc)))))) )))) -------------------------------------------------------------------------------- /cfdg/util.sls: -------------------------------------------------------------------------------- 1 | 2 | (library (psilab cfdg util) 3 | 4 | (export pi radians sq) 5 | 6 | (import (rnrs)) 7 | 8 | (define pi (* 2 (asin 1))) 9 | 10 | (define (radians n) 11 | (* n (/ pi 180.0))) 12 | 13 | (define (sq n) (* n n))) 14 | -------------------------------------------------------------------------------- /cons-wm/README: -------------------------------------------------------------------------------- 1 | 2 | * Notes 3 | 4 | The development version of Ypsilon is needed. 5 | 6 | dzen2 is used to display a pager. 7 | 8 | dmenu is used for the window menus. 9 | 10 | The first time you start cons-wm, there will be a noticeable delay 11 | while Ypsilon compiles the xlib library in the background. After 12 | that, it will start much faster. 13 | 14 | * Setup 15 | 16 | $ cd ~/scheme 17 | 18 | $ bzr branch lp:~derick-eddington/scheme-libraries/xitomatl 19 | 20 | $ git clone git://github.com/dharmatech/psilab.git 21 | 22 | * Running 23 | 24 | $ ypsilon ~/scheme/psilab/cons-wm/cons-wm.sps 25 | 26 | * Key bindings 27 | 28 | mod-key + return Start xterm 29 | mod-key + p Start dmenu_run 30 | mod-key + u Unmapped windows menu 31 | mod-key + h Hidden windows menu 32 | mod-key + q Exit 33 | mod-key + 0..9 Switch to desktop 34 | 35 | * Mouse bindings 36 | 37 | mod-key + button-1 Move window 38 | mod-key + button-2 Hide window 39 | mod-key + button-3 Resize window 40 | 41 | -------------------------------------------------------------------------------- /cons-wm/cons-wm.sps: -------------------------------------------------------------------------------- 1 | 2 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 3 | 4 | (import (rnrs) 5 | (xitomatl fmt) 6 | (ypsilon process) 7 | (psilab xlib ffi) 8 | (psilab xlib keysym) 9 | (psilab xlib util) 10 | (psilab xlib util x-get-geometry) 11 | (psilab xlib util x-query-tree) 12 | (psilab xlib util x-fetch-name)) 13 | 14 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 15 | 16 | (define (c-false? val) (= val 0)) 17 | (define (c-true? val) (not (c-false? val))) 18 | 19 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 20 | 21 | (define dpy #f) 22 | (define screen #f) 23 | (define root #f) 24 | 25 | (define move-cursor #f) 26 | (define resize-cursor #f) 27 | 28 | (define click-root-window 'click-root-window) 29 | (define click-client-window 'click-client-window) 30 | 31 | (define clients (make-eq-hashtable)) 32 | 33 | (define handlers (make-vector LASTEvent #f)) 34 | 35 | (define-record-type button (fields click mask button procedure)) 36 | 37 | (define-record-type key (fields mod keysym procedure)) 38 | 39 | (define num-lock-mask 0) 40 | 41 | (define (clean-mask mask) 42 | (bitwise-and mask (bitwise-not (bitwise-ior num-lock-mask LockMask)))) 43 | 44 | (define ButtonMask (bitwise-ior ButtonPressMask ButtonReleaseMask)) 45 | 46 | (define mouse-mask (bitwise-ior ButtonMask PointerMotionMask)) 47 | 48 | (define selected #f) 49 | 50 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 51 | ;; config 52 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 53 | 54 | (define border-width 5) 55 | 56 | ;; (define normal-border-color "#cccccc") 57 | ;; (define selected-border-color "#0066ff") 58 | 59 | (define normal-border-color "#9eeeee") 60 | (define selected-border-color "#55aaaa") 61 | 62 | (define menu-background-color "#e9ffe9") 63 | (define selected-menu-background-color "#448844") 64 | 65 | (define menu-foreground-color "black") 66 | (define selected-menu-foreground-color "white") 67 | 68 | (define other-background-color "#eaffff") 69 | 70 | (define mod-key Mod1Mask) 71 | 72 | (define use-grab #f) 73 | 74 | (define buttons #f) 75 | 76 | (define keys #f) 77 | 78 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 79 | 80 | (define get-color 81 | (let ((color (make-XColor))) 82 | (lambda (name) 83 | (let ((colormap (XDefaultColormap dpy screen))) 84 | (XAllocNamedColor dpy colormap name color color) 85 | (XColor-pixel color))))) 86 | 87 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 88 | 89 | (define (grab-buttons client focused) 90 | (XUngrabButton dpy AnyButton AnyModifier client) 91 | (if focused 92 | (for-each 93 | (lambda (b) 94 | (if (eq? (button-click b) click-client-window) 95 | (for-each 96 | (lambda (modifier) 97 | (XGrabButton dpy 98 | (button-button b) 99 | (bitwise-ior (button-mask b) modifier) 100 | client 101 | False ButtonMask GrabModeAsync GrabModeSync None 102 | None)) 103 | (list 0 LockMask num-lock-mask 104 | (bitwise-ior num-lock-mask LockMask))) 105 | (XGrabButton dpy AnyButton AnyModifier client False ButtonMask 106 | GrabModeAsync GrabModeSync None None))) 107 | buttons))) 108 | 109 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 110 | 111 | (define (grab-keys) 112 | (XUngrabKey dpy AnyKey AnyModifier root) 113 | (for-each 114 | (lambda (k) 115 | (let ((code (XKeysymToKeycode dpy (key-keysym k)))) 116 | ;; Kludge for now. Some FFIs return a Scheme char, others a number. 117 | (let ((code (if (char? code) (char->integer code) code))) 118 | (for-each 119 | (lambda (modifier) 120 | (XGrabKey dpy code (bitwise-ior (key-mod k) modifier) 121 | root True GrabModeAsync GrabModeAsync)) 122 | (list 0 LockMask num-lock-mask (bitwise-ior num-lock-mask LockMask)))))) 123 | keys)) 124 | 125 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 126 | 127 | (define (key-press ev) 128 | (let ((keysym (XKeycodeToKeysym dpy (XKeyEvent-keycode ev) 0))) 129 | (let ((key (find (lambda (k) 130 | (and (= (key-keysym k) keysym) 131 | (= (clean-mask (key-mod k)) 132 | (clean-mask (XKeyEvent-state ev))))) 133 | keys))) 134 | ((key-procedure key))))) 135 | 136 | (vector-set! handlers KeyPress key-press) 137 | 138 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 139 | 140 | (define (enter-notify ev) 141 | (cond ((and (not (= (XCrossingEvent-mode ev) NotifyNormal)) 142 | (not (= (XCrossingEvent-window ev) root))) 143 | (fmt #t " enter-notify : mode is not NotifyNormal" nl) #t) 144 | ((and (= (XCrossingEvent-detail ev) NotifyInferior) 145 | (not (= (XCrossingEvent-window ev) root))) 146 | (fmt #t " enter-notify : detail is NotifyInferior" nl) #t) 147 | ((hashtable-ref clients (XCrossingEvent-window ev) #f) => focus) 148 | (else (focus #f)))) 149 | 150 | (vector-set! handlers EnterNotify enter-notify) 151 | 152 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 153 | 154 | (define (focus-in ev) 155 | (if (and (integer? selected) 156 | (not (= (XFocusChangeEvent-window ev) selected))) 157 | (XSetInputFocus dpy selected RevertToPointerRoot CurrentTime))) 158 | 159 | (vector-set! handlers FocusIn focus-in) 160 | 161 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 162 | 163 | (define (manage id) 164 | (XSetWindowBorderWidth dpy id border-width) 165 | (XSetWindowBorder dpy id (get-color normal-border-color)) 166 | (XSelectInput dpy id (bitwise-ior EnterWindowMask 167 | FocusChangeMask 168 | PropertyChangeMask 169 | StructureNotifyMask)) 170 | (grab-buttons id #f) 171 | (hashtable-set! clients id id) 172 | (XMapWindow dpy id) 173 | (XSync dpy False)) 174 | 175 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 176 | 177 | (define map-request 178 | (let ((wa (make-XWindowAttributes))) 179 | (lambda (ev) 180 | (let ((id (XMapRequestEvent-window ev))) 181 | (if (and (c-true? (XGetWindowAttributes dpy id wa)) 182 | (= (XWindowAttributes-override_redirect wa) 0) 183 | (not (hashtable-ref clients id #f))) 184 | (manage id)))))) 185 | 186 | (vector-set! handlers MapRequest map-request) 187 | 188 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 189 | 190 | (define configure-request 191 | (let ((wc (make-XWindowChanges))) 192 | (lambda (ev) 193 | (XWindowChanges-x-set! wc (XConfigureRequestEvent-x ev)) 194 | (XWindowChanges-y-set! wc (XConfigureRequestEvent-y ev)) 195 | (XWindowChanges-width-set! wc (XConfigureRequestEvent-width ev)) 196 | (XWindowChanges-height-set! wc (XConfigureRequestEvent-height ev)) 197 | (XWindowChanges-border_width-set! wc (XConfigureRequestEvent-border_width ev)) 198 | (XWindowChanges-sibling-set! wc (XConfigureRequestEvent-above ev)) 199 | (XWindowChanges-stack_mode-set! wc (XConfigureRequestEvent-detail ev)) 200 | (XConfigureWindow dpy 201 | (XConfigureRequestEvent-window ev) 202 | (XConfigureRequestEvent-value_mask ev) 203 | wc) 204 | (XSync dpy False)))) 205 | 206 | (vector-set! handlers ConfigureRequest configure-request) 207 | 208 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 209 | 210 | (define (focus client) 211 | 212 | (fmt #t " focus : start" nl) 213 | 214 | (if (and selected (not (equal? client selected))) 215 | (begin 216 | (grab-buttons selected #f) 217 | (XSetWindowBorder dpy selected (get-color normal-border-color)))) 218 | 219 | (if client 220 | (begin 221 | (grab-buttons client #t) 222 | (XSetWindowBorder dpy client (get-color selected-border-color)) 223 | (XSetInputFocus dpy client RevertToPointerRoot CurrentTime)) 224 | (XSetInputFocus dpy root RevertToPointerRoot CurrentTime)) 225 | 226 | (set! selected client)) 227 | 228 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 229 | 230 | (define (button-press ev) 231 | (fmt #t " button-press : start" nl) 232 | (let ((client (hashtable-ref clients (XButtonEvent-window ev) #f))) 233 | (if client (focus client)) 234 | (let ((click (if client click-client-window click-root-window))) 235 | (let ((button 236 | (find 237 | (lambda (b) 238 | (and (eq? (button-click b) click) 239 | (= (button-button b) 240 | (XButtonEvent-button ev)) 241 | (= (clean-mask (button-mask b)) 242 | (clean-mask (XButtonEvent-state ev))))) 243 | buttons))) 244 | (if button 245 | ((button-procedure button))))))) 246 | 247 | (vector-set! handlers ButtonPress button-press) 248 | 249 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 250 | 251 | (define (destroy-notify ev) 252 | (let ((client (hashtable-ref clients (XDestroyWindowEvent-window ev) #f))) 253 | (if client 254 | (hashtable-delete! clients client)))) 255 | 256 | (vector-set! handlers DestroyNotify destroy-notify) 257 | 258 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 259 | 260 | (define (move-mouse) 261 | (fmt #t " move-mouse : start" nl) 262 | (let ((client selected)) 263 | (if (and client 264 | (= (XGrabPointer dpy root False mouse-mask 265 | GrabModeAsync GrabModeAsync 266 | None move-cursor CurrentTime) 267 | GrabSuccess)) 268 | (begin 269 | (XRaiseWindow dpy client) 270 | (if use-grab (XGrabServer dpy)) 271 | (let ((ev (make-XEvent))) 272 | (let loop () 273 | (XMaskEvent dpy 274 | (bitwise-ior mouse-mask 275 | ExposureMask 276 | SubstructureRedirectMask) 277 | ev) 278 | (let ((type (XAnyEvent-type ev))) 279 | (cond ((or (= type ConfigureRequest) 280 | (= type Expose) 281 | (= type MapRequest)) 282 | ((vector-ref handlers type) ev)) 283 | ((= type MotionNotify) 284 | (XMoveWindow dpy 285 | client 286 | (XMotionEvent-x ev) 287 | (XMotionEvent-y ev)) 288 | (XSync dpy False))) 289 | (if (not (= type ButtonRelease)) (loop))))) 290 | (if use-grab (XUngrabServer dpy)) 291 | (XUngrabPointer dpy CurrentTime))))) 292 | 293 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 294 | 295 | (define desktops-hidden (make-vector 10 '())) 296 | 297 | (define (hide-mouse) 298 | (XUnmapWindow dpy selected) 299 | (vector-set! desktops-hidden 300 | current-desktop 301 | (cons selected (vector-ref desktops-hidden current-desktop))) 302 | (set! selected #f) 303 | (update-dzen)) 304 | 305 | (define (unhide id) 306 | 307 | (vector-set! desktops-hidden 308 | current-desktop 309 | (remove id (vector-ref desktops-hidden current-desktop))) 310 | 311 | (XMapWindow dpy id) 312 | (update-dzen)) 313 | 314 | (define (hidden-window-names) 315 | (call-with-string-output-port 316 | (lambda (port) 317 | (fmt port " ") 318 | (for-each 319 | (lambda (name) 320 | (fmt port name " ")) 321 | (filter 322 | (lambda (name) name) 323 | (map 324 | (lambda (id) 325 | (x-fetch-name dpy id)) 326 | (vector-ref desktops-hidden current-desktop))))))) 327 | 328 | (define (dmenu-hidden) 329 | (guard (var 330 | (else (fmt #t " dmenu-hidden : " var nl))) 331 | (call-with-process-ports 332 | (process "dmenu" "-b" 333 | "-nb" menu-background-color 334 | "-sb" selected-menu-background-color 335 | "-nf" menu-foreground-color 336 | "-sf" selected-menu-foreground-color) 337 | (lambda (in out err) 338 | (let ((tbl (filter cdr 339 | (map 340 | (lambda (id) 341 | (cons id (x-fetch-name dpy id))) 342 | (vector-ref desktops-hidden current-desktop))))) 343 | (let ((i 0)) 344 | (for-each 345 | (lambda (cell) 346 | (fmt in i " " (cdr cell) nl) 347 | (set! i (+ i 1))) 348 | tbl)) 349 | (flush-output-port in) 350 | (close-port in) 351 | (let ((result (read out))) 352 | (if (integer? result) 353 | (unhide (car (list-ref tbl result))) 354 | (update-dzen)))))))) 355 | 356 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 357 | 358 | (define (resize-mouse) 359 | (let ((client selected)) 360 | (if (and client 361 | (= (XGrabPointer dpy root False mouse-mask 362 | GrabModeAsync GrabModeAsync 363 | None resize-cursor CurrentTime) 364 | GrabSuccess)) 365 | (begin 366 | (if use-grab (XGrabServer dpy)) 367 | (let ((ev (make-XEvent))) 368 | (define ResizeMask 369 | (bitwise-ior mouse-mask 370 | ExposureMask 371 | SubstructureRedirectMask)) 372 | (define client-x #f) 373 | (define client-y #f) 374 | (let ((info (x-get-geometry dpy client))) 375 | (set! client-x (x-get-geometry-info-x info)) 376 | (set! client-y (x-get-geometry-info-y info))) 377 | (let loop () 378 | (XMaskEvent dpy ResizeMask ev) 379 | (let ((type (XAnyEvent-type ev))) 380 | (cond ((or (= type ConfigureRequest) 381 | (= type Expose) 382 | (= type MapRequest)) 383 | ((vector-ref handlers type) ev)) 384 | ((= type MotionNotify) 385 | (let ((new-width (- (XMotionEvent-x ev) client-x)) 386 | (new-height (- (XMotionEvent-y ev) client-y))) 387 | (XResizeWindow dpy client new-width new-height) 388 | (XSync dpy False)))) 389 | (if (not (= type ButtonRelease)) 390 | (loop)))) 391 | (if use-grab (XUngrabServer dpy)) 392 | (XUngrabPointer dpy CurrentTime)))))) 393 | 394 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 395 | ;; Desktops 396 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 397 | 398 | (define is-viewable? 399 | (let ((wa (make-XWindowAttributes))) 400 | (lambda (id) 401 | (XGetWindowAttributes dpy id wa) 402 | (= (XWindowAttributes-map_state wa) IsViewable)))) 403 | 404 | (define (is-client? id) 405 | (hashtable-contains? clients id)) 406 | 407 | (define (mapped-client? id) 408 | (and (is-viewable? id) 409 | (is-client? id))) 410 | 411 | (define (mapped-clients) 412 | (filter mapped-client? 413 | (x-query-tree-info-children (x-query-tree dpy root)))) 414 | 415 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 416 | 417 | (define desktops (make-vector 10 '())) 418 | 419 | (define current-desktop 0) 420 | 421 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 422 | 423 | (define (switch-to-desktop i) 424 | 425 | (define (unmap-client id) 426 | (XUnmapWindow dpy id)) 427 | 428 | (define (map-client id) 429 | (XMapWindow dpy id)) 430 | 431 | (vector-set! desktops current-desktop (mapped-clients)) 432 | 433 | (for-each unmap-client (mapped-clients)) 434 | 435 | (if (vector-ref desktops i) 436 | (for-each map-client (vector-ref desktops i))) 437 | 438 | (set! current-desktop i) 439 | 440 | (if dzen-process-info (update-dzen))) 441 | 442 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 443 | 444 | (define (pager) 445 | (call-with-string-output-port 446 | (lambda (port) 447 | (fmt port "[") 448 | (let ((n (vector-length desktops))) 449 | (let loop ((i 0)) 450 | (if (>= i n) 451 | (fmt port "]") 452 | (begin 453 | (cond ((= i current-desktop) 454 | (fmt port "x")) 455 | ((not (null? (vector-ref desktops i))) 456 | (fmt port "-")) 457 | ((not (null? (vector-ref desktops-hidden i))) 458 | (fmt port "_")) 459 | (else 460 | (fmt port " "))) 461 | (if (< i (- n 1)) 462 | (fmt port "|")) 463 | (loop (+ i 1))))))))) 464 | 465 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 466 | ;; dzen 467 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 468 | 469 | ;; [ |_|_| |x| | |-| | | ] 470 | 471 | (define dzen-process-info #f) 472 | 473 | (define dzen-stdin #f) 474 | 475 | (if (= 0 (system "which dzen2")) 476 | (let ((info (process "dzen2" 477 | "-bg" other-background-color 478 | "-fg" menu-foreground-color))) 479 | (set! dzen-process-info info) 480 | (set! dzen-stdin 481 | (transcoded-port (list-ref info 1) (native-transcoder))))) 482 | 483 | (define (update-dzen) 484 | (fmt dzen-stdin (pager) (hidden-window-names) nl) 485 | (flush-output-port dzen-stdin)) 486 | 487 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 488 | ;; dmenu-unmapped 489 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 490 | 491 | (define (dmenu-unmapped) 492 | 493 | (define (not-viewable? c) 494 | (not (is-viewable? c))) 495 | 496 | (guard (var 497 | (else (fmt #t " dmenu-unmapped : " var nl))) 498 | 499 | (call-with-process-ports 500 | 501 | (process "dmenu" "-b" 502 | "-nb" menu-background-color 503 | "-sb" selected-menu-background-color 504 | "-nf" menu-foreground-color 505 | "-sf" selected-menu-foreground-color) 506 | 507 | (lambda (in out err) 508 | 509 | (let ((tbl (map 510 | (lambda (id) 511 | (cons id (x-fetch-name dpy id))) 512 | (filter not-viewable? 513 | (vector->list 514 | (hashtable-keys clients)))))) 515 | 516 | (let ((tbl (filter cdr tbl))) 517 | 518 | (let ((i 0)) 519 | (for-each 520 | (lambda (cell) 521 | (fmt in i " " (cdr cell) nl) 522 | (set! i (+ i 1))) 523 | tbl)) 524 | 525 | (flush-output-port in) 526 | 527 | (close-port in) 528 | 529 | (let ((result (read out))) 530 | 531 | (if (integer? result) 532 | 533 | (XMapWindow dpy (car (list-ref tbl result))))))))))) 534 | 535 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 536 | 537 | (set! buttons 538 | (list 539 | (make-button click-client-window mod-key Button1 move-mouse) 540 | (make-button click-client-window mod-key Button2 hide-mouse) 541 | (make-button click-client-window mod-key Button3 resize-mouse))) 542 | 543 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 544 | 545 | ;; (define (cycle-mapped-clients) 546 | ;; (let ((clients (mapped-clients))) 547 | ;; (if (>= (length clients) 2) 548 | ;; (let ((client (list-ref clients 1))) 549 | ;; (XRaiseWindow dpy client) 550 | ;; (focus client))))) 551 | 552 | (define (next-client) 553 | (let ((clients (mapped-clients))) 554 | (if (not (null? clients)) 555 | (let ((client (car clients))) 556 | (XRaiseWindow dpy client) 557 | (focus client))))) 558 | 559 | ;; (define (maximize) 560 | ;; (if (hashtable-ref clients selected #f) 561 | ;; (let ((root-info (x-get-geometry dpy root))) 562 | ;; (XResizeWindow dpy selected 563 | ;; (- (x-get-geometry-info-width root-info) 564 | ;; border-width 565 | ;; border-width) 566 | ;; (- (x-get-geometry-info-height root-info) 567 | ;; 18 ;; dzen-height 568 | ;; border-width 569 | ;; border-width)) 570 | ;; (XMoveWindow dpy selected 0 18)))) 571 | 572 | (define maximize 573 | (let ((last-client #f) 574 | (last-geom #f)) 575 | (lambda () 576 | (let ((client (hashtable-ref clients selected #f))) 577 | (cond ((and client 578 | (equal? client last-client)) 579 | (XResizeWindow dpy 580 | client 581 | (x-get-geometry-info-width last-geom) 582 | (x-get-geometry-info-height last-geom)) 583 | (XMoveWindow dpy 584 | client 585 | (x-get-geometry-info-x last-geom) 586 | (x-get-geometry-info-y last-geom)) 587 | (set! last-client #f)) 588 | (client 589 | (set! last-client client) 590 | (set! last-geom (x-get-geometry dpy client)) 591 | (let ((root-info (x-get-geometry dpy root))) 592 | (XResizeWindow dpy client 593 | (- (x-get-geometry-info-width root-info) 594 | border-width 595 | border-width) 596 | (- (x-get-geometry-info-height root-info) 597 | 18 ;; dzen-height 598 | border-width 599 | border-width)) 600 | (XMoveWindow dpy client 0 18)))))))) 601 | 602 | (define (dmenu-run) 603 | (system (fmt #f 604 | "dmenu_run -b" 605 | " -nb '" menu-background-color "'" 606 | " -sb '" selected-menu-background-color "'" 607 | " -nf '" menu-foreground-color "'" 608 | " -sf '" selected-menu-foreground-color "'" 609 | " &"))) 610 | 611 | (set! keys 612 | (list (make-key mod-key XK_Return (lambda () (system "xterm &"))) 613 | (make-key mod-key XK_e (lambda () (system "emacsclient -c &"))) 614 | (make-key mod-key XK_Tab next-client) 615 | (make-key mod-key XK_p dmenu-run) 616 | (make-key mod-key XK_u dmenu-unmapped) 617 | (make-key mod-key XK_h dmenu-hidden) 618 | (make-key mod-key XK_F9 maximize) 619 | (make-key mod-key XK_q exit) 620 | (make-key mod-key XK_1 (lambda () (switch-to-desktop 0))) 621 | (make-key mod-key XK_2 (lambda () (switch-to-desktop 1))) 622 | (make-key mod-key XK_3 (lambda () (switch-to-desktop 2))) 623 | (make-key mod-key XK_4 (lambda () (switch-to-desktop 3))) 624 | (make-key mod-key XK_5 (lambda () (switch-to-desktop 4))) 625 | (make-key mod-key XK_6 (lambda () (switch-to-desktop 5))) 626 | (make-key mod-key XK_7 (lambda () (switch-to-desktop 6))) 627 | (make-key mod-key XK_8 (lambda () (switch-to-desktop 7))) 628 | (make-key mod-key XK_9 (lambda () (switch-to-desktop 8))) 629 | (make-key mod-key XK_0 (lambda () (switch-to-desktop 9))))) 630 | 631 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 632 | 633 | (define event-loop 634 | (let ((ev (make-XEvent))) 635 | (lambda () 636 | (XSync dpy False) 637 | (let loop () 638 | (XNextEvent dpy ev) 639 | (fmt #t "event-loop : received event of type " (XAnyEvent-type ev) nl) 640 | (let ((handler (vector-ref handlers (XAnyEvent-type ev)))) 641 | (if handler 642 | (handler ev))) 643 | (loop))))) 644 | 645 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 646 | 647 | (set! dpy (XOpenDisplay (or (getenv "DISPLAY") 0))) 648 | 649 | (set! screen (XDefaultScreen dpy)) 650 | 651 | (set! root (XRootWindow dpy screen)) 652 | 653 | (set! move-cursor (XCreateFontCursor dpy XC_fleur)) 654 | (set! resize-cursor (XCreateFontCursor dpy XC_sizing)) 655 | 656 | (XSelectInput dpy root (bitwise-ior SubstructureRedirectMask 657 | SubstructureNotifyMask 658 | ButtonPressMask 659 | EnterWindowMask 660 | LeaveWindowMask 661 | StructureNotifyMask 662 | PropertyChangeMask)) 663 | 664 | (grab-keys) 665 | 666 | (XSetErrorHandler 667 | (lambda (dpy ee) 668 | (fmt #t "Error handler called" nl) 669 | 1)) 670 | 671 | (update-dzen) 672 | 673 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 674 | 675 | (fmt #t "cons-wm is setup" nl) 676 | 677 | (event-loop) 678 | 679 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 680 | 681 | -------------------------------------------------------------------------------- /xlib/compat.sls: -------------------------------------------------------------------------------- 1 | 2 | (library (psilab xlib compat) 3 | 4 | (export (rename (xlib:typedef typedef) 5 | (xlib:c-structure c-structure) 6 | (xlib:c-function c-function))) 7 | 8 | (import (rnrs) (ypsilon ffi) (ypsilon c-types)) 9 | 10 | (define lib-name "libX11.so") 11 | 12 | (define lib (load-shared-object lib-name)) 13 | 14 | (define ht-type-aliases (make-eq-hashtable)) 15 | 16 | (define get-primitive-type 17 | (lambda (type) 18 | (cond ((hashtable-ref ht-type-aliases type #f) 19 | => get-primitive-type) 20 | (else type)))) 21 | 22 | (define-syntax xlib:typedef 23 | (lambda (x) 24 | (syntax-case x () 25 | ((_ type new) 26 | (begin 27 | (hashtable-set! ht-type-aliases (syntax->datum #'new) (syntax->datum #'type)) 28 | #'(define-c-typedef new type)))))) 29 | 30 | (define-syntax xlib:c-structure 31 | (lambda (x) 32 | (syntax-case x () 33 | ((_ subform ...) 34 | #'(define-c-struct-type subform ...))))) 35 | 36 | (define-syntax xlib:c-function 37 | (lambda (x) 38 | (syntax-case x () 39 | ((_ ret name args) 40 | (with-syntax 41 | ((e0 (datum->syntax #'k (get-primitive-type (syntax->datum #'ret)))) 42 | (e1 (datum->syntax #'k (map get-primitive-type (syntax->datum #'args))))) 43 | #'(define name (c-function lib lib-name e0 name e1))))))) 44 | ) -------------------------------------------------------------------------------- /xlib/keysym.sls: -------------------------------------------------------------------------------- 1 | 2 | (library (psilab xlib keysym) 3 | 4 | (export XK_VoidSymbol 5 | XK_BackSpace 6 | XK_Tab 7 | XK_Linefeed 8 | XK_Clear 9 | XK_Return 10 | XK_Pause 11 | XK_Scroll_Lock 12 | XK_Sys_Req 13 | XK_Escape 14 | XK_Delete 15 | XK_Multi_key 16 | XK_Codeinput 17 | XK_SingleCandidate 18 | XK_MultipleCandidate 19 | XK_PreviousCandidate 20 | XK_Kanji 21 | XK_Muhenkan 22 | XK_Henkan_Mode 23 | XK_Henkan 24 | XK_Romaji 25 | XK_Hiragana 26 | XK_Katakana 27 | XK_Hiragana_Katakana 28 | XK_Zenkaku 29 | XK_Hankaku 30 | XK_Zenkaku_Hankaku 31 | XK_Touroku 32 | XK_Massyo 33 | XK_Kana_Lock 34 | XK_Kana_Shift 35 | XK_Eisu_Shift 36 | XK_Eisu_toggle 37 | XK_Kanji_Bangou 38 | XK_Zen_Koho 39 | XK_Mae_Koho 40 | XK_Home 41 | XK_Left 42 | XK_Up 43 | XK_Right 44 | XK_Down 45 | XK_Prior 46 | XK_Page_Up 47 | XK_Next 48 | XK_Page_Down 49 | XK_End 50 | XK_Begin 51 | XK_Select 52 | XK_Print 53 | XK_Execute 54 | XK_Insert 55 | XK_Undo 56 | XK_Redo 57 | XK_Menu 58 | XK_Find 59 | XK_Cancel 60 | XK_Help 61 | XK_Break 62 | XK_Mode_switch 63 | XK_script_switch 64 | XK_Num_Lock 65 | XK_KP_Space 66 | XK_KP_Tab 67 | XK_KP_Enter 68 | XK_KP_F1 69 | XK_KP_F2 70 | XK_KP_F3 71 | XK_KP_F4 72 | XK_KP_Home 73 | XK_KP_Left 74 | XK_KP_Up 75 | XK_KP_Right 76 | XK_KP_Down 77 | XK_KP_Prior 78 | XK_KP_Page_Up 79 | XK_KP_Next 80 | XK_KP_Page_Down 81 | XK_KP_End 82 | XK_KP_Begin 83 | XK_KP_Insert 84 | XK_KP_Delete 85 | XK_KP_Equal 86 | XK_KP_Multiply 87 | XK_KP_Add 88 | XK_KP_Separator 89 | XK_KP_Subtract 90 | XK_KP_Decimal 91 | XK_KP_Divide 92 | XK_KP_0 93 | XK_KP_1 94 | XK_KP_2 95 | XK_KP_3 96 | XK_KP_4 97 | XK_KP_5 98 | XK_KP_6 99 | XK_KP_7 100 | XK_KP_8 101 | XK_KP_9 102 | XK_F1 103 | XK_F2 104 | XK_F3 105 | XK_F4 106 | XK_F5 107 | XK_F6 108 | XK_F7 109 | XK_F8 110 | XK_F9 111 | XK_F10 112 | XK_F11 113 | XK_L1 114 | XK_F12 115 | XK_L2 116 | XK_F13 117 | XK_L3 118 | XK_F14 119 | XK_L4 120 | XK_F15 121 | XK_L5 122 | XK_F16 123 | XK_L6 124 | XK_F17 125 | XK_L7 126 | XK_F18 127 | XK_L8 128 | XK_F19 129 | XK_L9 130 | XK_F20 131 | XK_L10 132 | XK_F21 133 | XK_R1 134 | XK_F22 135 | XK_R2 136 | XK_F23 137 | XK_R3 138 | XK_F24 139 | XK_R4 140 | XK_F25 141 | XK_R5 142 | XK_F26 143 | XK_R6 144 | XK_F27 145 | XK_R7 146 | XK_F28 147 | XK_R8 148 | XK_F29 149 | XK_R9 150 | XK_F30 151 | XK_R10 152 | XK_F31 153 | XK_R11 154 | XK_F32 155 | XK_R12 156 | XK_F33 157 | XK_R13 158 | XK_F34 159 | XK_R14 160 | XK_F35 161 | XK_R15 162 | 163 | 164 | 165 | XK_Shift_L 166 | XK_Shift_R 167 | XK_Control_L 168 | XK_Control_R 169 | XK_Caps_Lock 170 | XK_Shift_Lock 171 | 172 | XK_Meta_L 173 | XK_Meta_R 174 | XK_Alt_L 175 | XK_Alt_R 176 | XK_Super_L 177 | XK_Super_R 178 | XK_Hyper_L 179 | XK_Hyper_R 180 | 181 | 182 | 183 | 184 | XK_ISO_Lock 185 | XK_ISO_Level2_Latch 186 | XK_ISO_Level3_Shift 187 | XK_ISO_Level3_Latch 188 | XK_ISO_Level3_Lock 189 | XK_ISO_Level5_Shift 190 | XK_ISO_Level5_Latch 191 | XK_ISO_Level5_Lock 192 | XK_ISO_Group_Shift 193 | XK_ISO_Group_Latch 194 | XK_ISO_Group_Lock 195 | XK_ISO_Next_Group 196 | XK_ISO_Next_Group_Lock 197 | XK_ISO_Prev_Group 198 | XK_ISO_Prev_Group_Lock 199 | XK_ISO_First_Group 200 | XK_ISO_First_Group_Lock 201 | XK_ISO_Last_Group 202 | XK_ISO_Last_Group_Lock 203 | 204 | XK_ISO_Left_Tab 205 | XK_ISO_Move_Line_Up 206 | XK_ISO_Move_Line_Down 207 | XK_ISO_Partial_Line_Up 208 | XK_ISO_Partial_Line_Down 209 | XK_ISO_Partial_Space_Left 210 | XK_ISO_Partial_Space_Right 211 | XK_ISO_Set_Margin_Left 212 | XK_ISO_Set_Margin_Right 213 | XK_ISO_Release_Margin_Left 214 | XK_ISO_Release_Margin_Right 215 | XK_ISO_Release_Both_Margins 216 | XK_ISO_Fast_Cursor_Left 217 | XK_ISO_Fast_Cursor_Right 218 | XK_ISO_Fast_Cursor_Up 219 | XK_ISO_Fast_Cursor_Down 220 | XK_ISO_Continuous_Underline 221 | XK_ISO_Discontinuous_Underline 222 | XK_ISO_Emphasize 223 | XK_ISO_Center_Object 224 | XK_ISO_Enter 225 | 226 | XK_dead_grave 227 | XK_dead_acute 228 | XK_dead_circumflex 229 | XK_dead_tilde 230 | XK_dead_macron 231 | XK_dead_breve 232 | XK_dead_abovedot 233 | XK_dead_diaeresis 234 | XK_dead_abovering 235 | XK_dead_doubleacute 236 | XK_dead_caron 237 | XK_dead_cedilla 238 | XK_dead_ogonek 239 | XK_dead_iota 240 | XK_dead_voiced_sound 241 | XK_dead_semivoiced_sound 242 | XK_dead_belowdot 243 | XK_dead_hook 244 | XK_dead_horn 245 | XK_dead_stroke 246 | XK_dead_abovecomma 247 | XK_dead_psili 248 | XK_dead_abovereversedcomma 249 | XK_dead_dasia 250 | 251 | XK_First_Virtual_Screen 252 | XK_Prev_Virtual_Screen 253 | XK_Next_Virtual_Screen 254 | XK_Last_Virtual_Screen 255 | XK_Terminate_Server 256 | 257 | XK_AccessX_Enable 258 | XK_AccessX_Feedback_Enable 259 | XK_RepeatKeys_Enable 260 | XK_SlowKeys_Enable 261 | XK_BounceKeys_Enable 262 | XK_StickyKeys_Enable 263 | XK_MouseKeys_Enable 264 | XK_MouseKeys_Accel_Enable 265 | XK_Overlay1_Enable 266 | XK_Overlay2_Enable 267 | XK_AudibleBell_Enable 268 | 269 | XK_Pointer_Left 270 | XK_Pointer_Right 271 | XK_Pointer_Up 272 | XK_Pointer_Down 273 | XK_Pointer_UpLeft 274 | XK_Pointer_UpRight 275 | XK_Pointer_DownLeft 276 | XK_Pointer_DownRight 277 | XK_Pointer_Button_Dflt 278 | XK_Pointer_Button1 279 | XK_Pointer_Button2 280 | XK_Pointer_Button3 281 | XK_Pointer_Button4 282 | XK_Pointer_Button5 283 | XK_Pointer_DblClick_Dflt 284 | XK_Pointer_DblClick1 285 | XK_Pointer_DblClick2 286 | XK_Pointer_DblClick3 287 | XK_Pointer_DblClick4 288 | XK_Pointer_DblClick5 289 | XK_Pointer_Drag_Dflt 290 | XK_Pointer_Drag1 291 | XK_Pointer_Drag2 292 | XK_Pointer_Drag3 293 | XK_Pointer_Drag4 294 | XK_Pointer_Drag5 295 | 296 | XK_Pointer_EnableKeys 297 | XK_Pointer_Accelerate 298 | XK_Pointer_DfltBtnNext 299 | XK_Pointer_DfltBtnPrev 300 | 301 | 302 | 303 | XK_3270_Duplicate 304 | XK_3270_FieldMark 305 | XK_3270_Right2 306 | XK_3270_Left2 307 | XK_3270_BackTab 308 | XK_3270_EraseEOF 309 | XK_3270_EraseInput 310 | XK_3270_Reset 311 | XK_3270_Quit 312 | XK_3270_PA1 313 | XK_3270_PA2 314 | XK_3270_PA3 315 | XK_3270_Test 316 | XK_3270_Attn 317 | XK_3270_CursorBlink 318 | XK_3270_AltCursor 319 | XK_3270_KeyClick 320 | XK_3270_Jump 321 | XK_3270_Ident 322 | XK_3270_Rule 323 | XK_3270_Copy 324 | XK_3270_Play 325 | XK_3270_Setup 326 | XK_3270_Record 327 | XK_3270_ChangeScreen 328 | XK_3270_DeleteWord 329 | XK_3270_ExSelect 330 | XK_3270_CursorSelect 331 | XK_3270_PrintScreen 332 | XK_3270_Enter 333 | 334 | 335 | XK_space 336 | XK_exclam 337 | XK_quotedbl 338 | XK_numbersign 339 | XK_dollar 340 | XK_percent 341 | XK_ampersand 342 | XK_apostrophe 343 | XK_quoteright 344 | XK_parenleft 345 | XK_parenright 346 | XK_asterisk 347 | XK_plus 348 | XK_comma 349 | XK_minus 350 | XK_period 351 | XK_slash 352 | XK_0 353 | XK_1 354 | XK_2 355 | XK_3 356 | XK_4 357 | XK_5 358 | XK_6 359 | XK_7 360 | XK_8 361 | XK_9 362 | XK_colon 363 | XK_semicolon 364 | XK_less 365 | XK_equal 366 | XK_greater 367 | XK_question 368 | XK_at 369 | XK_A 370 | XK_B 371 | XK_C 372 | XK_D 373 | XK_E 374 | XK_F 375 | XK_G 376 | XK_H 377 | XK_I 378 | XK_J 379 | XK_K 380 | XK_L 381 | XK_M 382 | XK_N 383 | XK_O 384 | XK_P 385 | XK_Q 386 | XK_R 387 | XK_S 388 | XK_T 389 | XK_U 390 | XK_V 391 | XK_W 392 | XK_X 393 | XK_Y 394 | XK_Z 395 | XK_bracketleft 396 | XK_backslash 397 | XK_bracketright 398 | XK_asciicircum 399 | XK_underscore 400 | XK_grave 401 | XK_quoteleft 402 | XK_a 403 | XK_b 404 | XK_c 405 | XK_d 406 | XK_e 407 | XK_f 408 | XK_g 409 | XK_h 410 | XK_i 411 | XK_j 412 | XK_k 413 | XK_l 414 | XK_m 415 | XK_n 416 | XK_o 417 | XK_p 418 | XK_q 419 | XK_r 420 | XK_s 421 | XK_t 422 | XK_u 423 | XK_v 424 | XK_w 425 | XK_x 426 | XK_y 427 | XK_z 428 | XK_braceleft 429 | XK_bar 430 | XK_braceright 431 | XK_asciitilde 432 | 433 | XK_nobreakspace 434 | XK_exclamdown 435 | XK_cent 436 | XK_sterling 437 | XK_currency 438 | XK_yen 439 | XK_brokenbar 440 | XK_section 441 | XK_diaeresis 442 | XK_copyright 443 | XK_ordfeminine 444 | XK_guillemotleft 445 | XK_notsign 446 | XK_hyphen 447 | XK_registered 448 | XK_macron 449 | XK_degree 450 | XK_plusminus 451 | XK_twosuperior 452 | XK_threesuperior 453 | XK_acute 454 | XK_mu 455 | XK_paragraph 456 | XK_periodcentered 457 | XK_cedilla 458 | XK_onesuperior 459 | XK_masculine 460 | XK_guillemotright 461 | XK_onequarter 462 | XK_onehalf 463 | XK_threequarters 464 | XK_questiondown 465 | XK_Agrave 466 | XK_Aacute 467 | XK_Acircumflex 468 | XK_Atilde 469 | XK_Adiaeresis 470 | XK_Aring 471 | XK_AE 472 | XK_Ccedilla 473 | XK_Egrave 474 | XK_Eacute 475 | XK_Ecircumflex 476 | XK_Ediaeresis 477 | XK_Igrave 478 | XK_Iacute 479 | XK_Icircumflex 480 | XK_Idiaeresis 481 | XK_ETH 482 | XK_Eth 483 | XK_Ntilde 484 | XK_Ograve 485 | XK_Oacute 486 | XK_Ocircumflex 487 | XK_Otilde 488 | XK_Odiaeresis 489 | XK_multiply 490 | XK_Oslash 491 | XK_Ooblique 492 | XK_Ugrave 493 | XK_Uacute 494 | XK_Ucircumflex 495 | XK_Udiaeresis 496 | XK_Yacute 497 | XK_THORN 498 | XK_Thorn 499 | XK_ssharp 500 | XK_agrave 501 | XK_aacute 502 | XK_acircumflex 503 | XK_atilde 504 | XK_adiaeresis 505 | XK_aring 506 | XK_ae 507 | XK_ccedilla 508 | XK_egrave 509 | XK_eacute 510 | XK_ecircumflex 511 | XK_ediaeresis 512 | XK_igrave 513 | XK_iacute 514 | XK_icircumflex 515 | XK_idiaeresis 516 | XK_eth 517 | XK_ntilde 518 | XK_ograve 519 | XK_oacute 520 | XK_ocircumflex 521 | XK_otilde 522 | XK_odiaeresis 523 | XK_division 524 | XK_oslash 525 | XK_ooblique 526 | XK_ugrave 527 | XK_uacute 528 | XK_ucircumflex 529 | XK_udiaeresis 530 | XK_yacute 531 | XK_thorn 532 | XK_ydiaeresis) 533 | 534 | (import (rnrs)) 535 | 536 | (define XK_VoidSymbol #xffffff) 537 | (define XK_BackSpace #xff08) 538 | (define XK_Tab #xff09) 539 | (define XK_Linefeed #xff0a) 540 | (define XK_Clear #xff0b) 541 | (define XK_Return #xff0d) 542 | (define XK_Pause #xff13) 543 | (define XK_Scroll_Lock #xff14) 544 | (define XK_Sys_Req #xff15) 545 | (define XK_Escape #xff1b) 546 | (define XK_Delete #xffff) 547 | (define XK_Multi_key #xff20) 548 | (define XK_Codeinput #xff37) 549 | (define XK_SingleCandidate #xff3c) 550 | (define XK_MultipleCandidate #xff3d) 551 | (define XK_PreviousCandidate #xff3e) 552 | (define XK_Kanji #xff21) 553 | (define XK_Muhenkan #xff22) 554 | (define XK_Henkan_Mode #xff23) 555 | (define XK_Henkan #xff23) 556 | (define XK_Romaji #xff24) 557 | (define XK_Hiragana #xff25) 558 | (define XK_Katakana #xff26) 559 | (define XK_Hiragana_Katakana #xff27) 560 | (define XK_Zenkaku #xff28) 561 | (define XK_Hankaku #xff29) 562 | (define XK_Zenkaku_Hankaku #xff2a) 563 | (define XK_Touroku #xff2b) 564 | (define XK_Massyo #xff2c) 565 | (define XK_Kana_Lock #xff2d) 566 | (define XK_Kana_Shift #xff2e) 567 | (define XK_Eisu_Shift #xff2f) 568 | (define XK_Eisu_toggle #xff30) 569 | (define XK_Kanji_Bangou #xff37) 570 | (define XK_Zen_Koho #xff3d) 571 | (define XK_Mae_Koho #xff3e) 572 | (define XK_Home #xff50) 573 | (define XK_Left #xff51) 574 | (define XK_Up #xff52) 575 | (define XK_Right #xff53) 576 | (define XK_Down #xff54) 577 | (define XK_Prior #xff55) 578 | (define XK_Page_Up #xff55) 579 | (define XK_Next #xff56) 580 | (define XK_Page_Down #xff56) 581 | (define XK_End #xff57) 582 | (define XK_Begin #xff58) 583 | (define XK_Select #xff60) 584 | (define XK_Print #xff61) 585 | (define XK_Execute #xff62) 586 | (define XK_Insert #xff63) 587 | (define XK_Undo #xff65) 588 | (define XK_Redo #xff66) 589 | (define XK_Menu #xff67) 590 | (define XK_Find #xff68) 591 | (define XK_Cancel #xff69) 592 | (define XK_Help #xff6a) 593 | (define XK_Break #xff6b) 594 | (define XK_Mode_switch #xff7e) 595 | (define XK_script_switch #xff7e) 596 | (define XK_Num_Lock #xff7f) 597 | (define XK_KP_Space #xff80) 598 | (define XK_KP_Tab #xff89) 599 | (define XK_KP_Enter #xff8d) 600 | (define XK_KP_F1 #xff91) 601 | (define XK_KP_F2 #xff92) 602 | (define XK_KP_F3 #xff93) 603 | (define XK_KP_F4 #xff94) 604 | (define XK_KP_Home #xff95) 605 | (define XK_KP_Left #xff96) 606 | (define XK_KP_Up #xff97) 607 | (define XK_KP_Right #xff98) 608 | (define XK_KP_Down #xff99) 609 | (define XK_KP_Prior #xff9a) 610 | (define XK_KP_Page_Up #xff9a) 611 | (define XK_KP_Next #xff9b) 612 | (define XK_KP_Page_Down #xff9b) 613 | (define XK_KP_End #xff9c) 614 | (define XK_KP_Begin #xff9d) 615 | (define XK_KP_Insert #xff9e) 616 | (define XK_KP_Delete #xff9f) 617 | (define XK_KP_Equal #xffbd) 618 | (define XK_KP_Multiply #xffaa) 619 | (define XK_KP_Add #xffab) 620 | (define XK_KP_Separator #xffac) 621 | (define XK_KP_Subtract #xffad) 622 | (define XK_KP_Decimal #xffae) 623 | (define XK_KP_Divide #xffaf) 624 | (define XK_KP_0 #xffb0) 625 | (define XK_KP_1 #xffb1) 626 | (define XK_KP_2 #xffb2) 627 | (define XK_KP_3 #xffb3) 628 | (define XK_KP_4 #xffb4) 629 | (define XK_KP_5 #xffb5) 630 | (define XK_KP_6 #xffb6) 631 | (define XK_KP_7 #xffb7) 632 | (define XK_KP_8 #xffb8) 633 | (define XK_KP_9 #xffb9) 634 | (define XK_F1 #xffbe) 635 | (define XK_F2 #xffbf) 636 | (define XK_F3 #xffc0) 637 | (define XK_F4 #xffc1) 638 | (define XK_F5 #xffc2) 639 | (define XK_F6 #xffc3) 640 | (define XK_F7 #xffc4) 641 | (define XK_F8 #xffc5) 642 | (define XK_F9 #xffc6) 643 | (define XK_F10 #xffc7) 644 | (define XK_F11 #xffc8) 645 | (define XK_L1 #xffc8) 646 | (define XK_F12 #xffc9) 647 | (define XK_L2 #xffc9) 648 | (define XK_F13 #xffca) 649 | (define XK_L3 #xffca) 650 | (define XK_F14 #xffcb) 651 | (define XK_L4 #xffcb) 652 | (define XK_F15 #xffcc) 653 | (define XK_L5 #xffcc) 654 | (define XK_F16 #xffcd) 655 | (define XK_L6 #xffcd) 656 | (define XK_F17 #xffce) 657 | (define XK_L7 #xffce) 658 | (define XK_F18 #xffcf) 659 | (define XK_L8 #xffcf) 660 | (define XK_F19 #xffd0) 661 | (define XK_L9 #xffd0) 662 | (define XK_F20 #xffd1) 663 | (define XK_L10 #xffd1) 664 | (define XK_F21 #xffd2) 665 | (define XK_R1 #xffd2) 666 | (define XK_F22 #xffd3) 667 | (define XK_R2 #xffd3) 668 | (define XK_F23 #xffd4) 669 | (define XK_R3 #xffd4) 670 | (define XK_F24 #xffd5) 671 | (define XK_R4 #xffd5) 672 | (define XK_F25 #xffd6) 673 | (define XK_R5 #xffd6) 674 | (define XK_F26 #xffd7) 675 | (define XK_R6 #xffd7) 676 | (define XK_F27 #xffd8) 677 | (define XK_R7 #xffd8) 678 | (define XK_F28 #xffd9) 679 | (define XK_R8 #xffd9) 680 | (define XK_F29 #xffda) 681 | (define XK_R9 #xffda) 682 | (define XK_F30 #xffdb) 683 | (define XK_R10 #xffdb) 684 | (define XK_F31 #xffdc) 685 | (define XK_R11 #xffdc) 686 | (define XK_F32 #xffdd) 687 | (define XK_R12 #xffdd) 688 | (define XK_F33 #xffde) 689 | (define XK_R13 #xffde) 690 | (define XK_F34 #xffdf) 691 | (define XK_R14 #xffdf) 692 | (define XK_F35 #xffe0) 693 | (define XK_R15 #xffe0) 694 | 695 | 696 | 697 | (define XK_Shift_L #xffe1) 698 | (define XK_Shift_R #xffe2) 699 | (define XK_Control_L #xffe3) 700 | (define XK_Control_R #xffe4) 701 | (define XK_Caps_Lock #xffe5) 702 | (define XK_Shift_Lock #xffe6) 703 | 704 | (define XK_Meta_L #xffe7) 705 | (define XK_Meta_R #xffe8) 706 | (define XK_Alt_L #xffe9) 707 | (define XK_Alt_R #xffea) 708 | (define XK_Super_L #xffeb) 709 | (define XK_Super_R #xffec) 710 | (define XK_Hyper_L #xffed) 711 | (define XK_Hyper_R #xffee) 712 | 713 | 714 | 715 | 716 | (define XK_ISO_Lock #xfe01) 717 | (define XK_ISO_Level2_Latch #xfe02) 718 | (define XK_ISO_Level3_Shift #xfe03) 719 | (define XK_ISO_Level3_Latch #xfe04) 720 | (define XK_ISO_Level3_Lock #xfe05) 721 | (define XK_ISO_Level5_Shift #xfe11) 722 | (define XK_ISO_Level5_Latch #xfe12) 723 | (define XK_ISO_Level5_Lock #xfe13) 724 | (define XK_ISO_Group_Shift #xff7e) 725 | (define XK_ISO_Group_Latch #xfe06) 726 | (define XK_ISO_Group_Lock #xfe07) 727 | (define XK_ISO_Next_Group #xfe08) 728 | (define XK_ISO_Next_Group_Lock #xfe09) 729 | (define XK_ISO_Prev_Group #xfe0a) 730 | (define XK_ISO_Prev_Group_Lock #xfe0b) 731 | (define XK_ISO_First_Group #xfe0c) 732 | (define XK_ISO_First_Group_Lock #xfe0d) 733 | (define XK_ISO_Last_Group #xfe0e) 734 | (define XK_ISO_Last_Group_Lock #xfe0f) 735 | 736 | (define XK_ISO_Left_Tab #xfe20) 737 | (define XK_ISO_Move_Line_Up #xfe21) 738 | (define XK_ISO_Move_Line_Down #xfe22) 739 | (define XK_ISO_Partial_Line_Up #xfe23) 740 | (define XK_ISO_Partial_Line_Down #xfe24) 741 | (define XK_ISO_Partial_Space_Left #xfe25) 742 | (define XK_ISO_Partial_Space_Right #xfe26) 743 | (define XK_ISO_Set_Margin_Left #xfe27) 744 | (define XK_ISO_Set_Margin_Right #xfe28) 745 | (define XK_ISO_Release_Margin_Left #xfe29) 746 | (define XK_ISO_Release_Margin_Right #xfe2a) 747 | (define XK_ISO_Release_Both_Margins #xfe2b) 748 | (define XK_ISO_Fast_Cursor_Left #xfe2c) 749 | (define XK_ISO_Fast_Cursor_Right #xfe2d) 750 | (define XK_ISO_Fast_Cursor_Up #xfe2e) 751 | (define XK_ISO_Fast_Cursor_Down #xfe2f) 752 | (define XK_ISO_Continuous_Underline #xfe30) 753 | (define XK_ISO_Discontinuous_Underline #xfe31) 754 | (define XK_ISO_Emphasize #xfe32) 755 | (define XK_ISO_Center_Object #xfe33) 756 | (define XK_ISO_Enter #xfe34) 757 | 758 | (define XK_dead_grave #xfe50) 759 | (define XK_dead_acute #xfe51) 760 | (define XK_dead_circumflex #xfe52) 761 | (define XK_dead_tilde #xfe53) 762 | (define XK_dead_macron #xfe54) 763 | (define XK_dead_breve #xfe55) 764 | (define XK_dead_abovedot #xfe56) 765 | (define XK_dead_diaeresis #xfe57) 766 | (define XK_dead_abovering #xfe58) 767 | (define XK_dead_doubleacute #xfe59) 768 | (define XK_dead_caron #xfe5a) 769 | (define XK_dead_cedilla #xfe5b) 770 | (define XK_dead_ogonek #xfe5c) 771 | (define XK_dead_iota #xfe5d) 772 | (define XK_dead_voiced_sound #xfe5e) 773 | (define XK_dead_semivoiced_sound #xfe5f) 774 | (define XK_dead_belowdot #xfe60) 775 | (define XK_dead_hook #xfe61) 776 | (define XK_dead_horn #xfe62) 777 | (define XK_dead_stroke #xfe63) 778 | (define XK_dead_abovecomma #xfe64) 779 | (define XK_dead_psili #xfe64) 780 | (define XK_dead_abovereversedcomma #xfe65) 781 | (define XK_dead_dasia #xfe66) 782 | 783 | (define XK_First_Virtual_Screen #xfed0) 784 | (define XK_Prev_Virtual_Screen #xfed1) 785 | (define XK_Next_Virtual_Screen #xfed2) 786 | (define XK_Last_Virtual_Screen #xfed4) 787 | (define XK_Terminate_Server #xfed5) 788 | 789 | (define XK_AccessX_Enable #xfe70) 790 | (define XK_AccessX_Feedback_Enable #xfe71) 791 | (define XK_RepeatKeys_Enable #xfe72) 792 | (define XK_SlowKeys_Enable #xfe73) 793 | (define XK_BounceKeys_Enable #xfe74) 794 | (define XK_StickyKeys_Enable #xfe75) 795 | (define XK_MouseKeys_Enable #xfe76) 796 | (define XK_MouseKeys_Accel_Enable #xfe77) 797 | (define XK_Overlay1_Enable #xfe78) 798 | (define XK_Overlay2_Enable #xfe79) 799 | (define XK_AudibleBell_Enable #xfe7a) 800 | 801 | (define XK_Pointer_Left #xfee0) 802 | (define XK_Pointer_Right #xfee1) 803 | (define XK_Pointer_Up #xfee2) 804 | (define XK_Pointer_Down #xfee3) 805 | (define XK_Pointer_UpLeft #xfee4) 806 | (define XK_Pointer_UpRight #xfee5) 807 | (define XK_Pointer_DownLeft #xfee6) 808 | (define XK_Pointer_DownRight #xfee7) 809 | (define XK_Pointer_Button_Dflt #xfee8) 810 | (define XK_Pointer_Button1 #xfee9) 811 | (define XK_Pointer_Button2 #xfeea) 812 | (define XK_Pointer_Button3 #xfeeb) 813 | (define XK_Pointer_Button4 #xfeec) 814 | (define XK_Pointer_Button5 #xfeed) 815 | (define XK_Pointer_DblClick_Dflt #xfeee) 816 | (define XK_Pointer_DblClick1 #xfeef) 817 | (define XK_Pointer_DblClick2 #xfef0) 818 | (define XK_Pointer_DblClick3 #xfef1) 819 | (define XK_Pointer_DblClick4 #xfef2) 820 | (define XK_Pointer_DblClick5 #xfef3) 821 | (define XK_Pointer_Drag_Dflt #xfef4) 822 | (define XK_Pointer_Drag1 #xfef5) 823 | (define XK_Pointer_Drag2 #xfef6) 824 | (define XK_Pointer_Drag3 #xfef7) 825 | (define XK_Pointer_Drag4 #xfef8) 826 | (define XK_Pointer_Drag5 #xfefd) 827 | 828 | (define XK_Pointer_EnableKeys #xfef9) 829 | (define XK_Pointer_Accelerate #xfefa) 830 | (define XK_Pointer_DfltBtnNext #xfefb) 831 | (define XK_Pointer_DfltBtnPrev #xfefc) 832 | 833 | 834 | 835 | (define XK_3270_Duplicate #xfd01) 836 | (define XK_3270_FieldMark #xfd02) 837 | (define XK_3270_Right2 #xfd03) 838 | (define XK_3270_Left2 #xfd04) 839 | (define XK_3270_BackTab #xfd05) 840 | (define XK_3270_EraseEOF #xfd06) 841 | (define XK_3270_EraseInput #xfd07) 842 | (define XK_3270_Reset #xfd08) 843 | (define XK_3270_Quit #xfd09) 844 | (define XK_3270_PA1 #xfd0a) 845 | (define XK_3270_PA2 #xfd0b) 846 | (define XK_3270_PA3 #xfd0c) 847 | (define XK_3270_Test #xfd0d) 848 | (define XK_3270_Attn #xfd0e) 849 | (define XK_3270_CursorBlink #xfd0f) 850 | (define XK_3270_AltCursor #xfd10) 851 | (define XK_3270_KeyClick #xfd11) 852 | (define XK_3270_Jump #xfd12) 853 | (define XK_3270_Ident #xfd13) 854 | (define XK_3270_Rule #xfd14) 855 | (define XK_3270_Copy #xfd15) 856 | (define XK_3270_Play #xfd16) 857 | (define XK_3270_Setup #xfd17) 858 | (define XK_3270_Record #xfd18) 859 | (define XK_3270_ChangeScreen #xfd19) 860 | (define XK_3270_DeleteWord #xfd1a) 861 | (define XK_3270_ExSelect #xfd1b) 862 | (define XK_3270_CursorSelect #xfd1c) 863 | (define XK_3270_PrintScreen #xfd1d) 864 | (define XK_3270_Enter #xfd1e) 865 | 866 | 867 | (define XK_space #x0020) 868 | (define XK_exclam #x0021) 869 | (define XK_quotedbl #x0022) 870 | (define XK_numbersign #x0023) 871 | (define XK_dollar #x0024) 872 | (define XK_percent #x0025) 873 | (define XK_ampersand #x0026) 874 | (define XK_apostrophe #x0027) 875 | (define XK_quoteright #x0027) 876 | (define XK_parenleft #x0028) 877 | (define XK_parenright #x0029) 878 | (define XK_asterisk #x002a) 879 | (define XK_plus #x002b) 880 | (define XK_comma #x002c) 881 | (define XK_minus #x002d) 882 | (define XK_period #x002e) 883 | (define XK_slash #x002f) 884 | (define XK_0 #x0030) 885 | (define XK_1 #x0031) 886 | (define XK_2 #x0032) 887 | (define XK_3 #x0033) 888 | (define XK_4 #x0034) 889 | (define XK_5 #x0035) 890 | (define XK_6 #x0036) 891 | (define XK_7 #x0037) 892 | (define XK_8 #x0038) 893 | (define XK_9 #x0039) 894 | (define XK_colon #x003a) 895 | (define XK_semicolon #x003b) 896 | (define XK_less #x003c) 897 | (define XK_equal #x003d) 898 | (define XK_greater #x003e) 899 | (define XK_question #x003f) 900 | (define XK_at #x0040) 901 | (define XK_A #x0041) 902 | (define XK_B #x0042) 903 | (define XK_C #x0043) 904 | (define XK_D #x0044) 905 | (define XK_E #x0045) 906 | (define XK_F #x0046) 907 | (define XK_G #x0047) 908 | (define XK_H #x0048) 909 | (define XK_I #x0049) 910 | (define XK_J #x004a) 911 | (define XK_K #x004b) 912 | (define XK_L #x004c) 913 | (define XK_M #x004d) 914 | (define XK_N #x004e) 915 | (define XK_O #x004f) 916 | (define XK_P #x0050) 917 | (define XK_Q #x0051) 918 | (define XK_R #x0052) 919 | (define XK_S #x0053) 920 | (define XK_T #x0054) 921 | (define XK_U #x0055) 922 | (define XK_V #x0056) 923 | (define XK_W #x0057) 924 | (define XK_X #x0058) 925 | (define XK_Y #x0059) 926 | (define XK_Z #x005a) 927 | (define XK_bracketleft #x005b) 928 | (define XK_backslash #x005c) 929 | (define XK_bracketright #x005d) 930 | (define XK_asciicircum #x005e) 931 | (define XK_underscore #x005f) 932 | (define XK_grave #x0060) 933 | (define XK_quoteleft #x0060) 934 | (define XK_a #x0061) 935 | (define XK_b #x0062) 936 | (define XK_c #x0063) 937 | (define XK_d #x0064) 938 | (define XK_e #x0065) 939 | (define XK_f #x0066) 940 | (define XK_g #x0067) 941 | (define XK_h #x0068) 942 | (define XK_i #x0069) 943 | (define XK_j #x006a) 944 | (define XK_k #x006b) 945 | (define XK_l #x006c) 946 | (define XK_m #x006d) 947 | (define XK_n #x006e) 948 | (define XK_o #x006f) 949 | (define XK_p #x0070) 950 | (define XK_q #x0071) 951 | (define XK_r #x0072) 952 | (define XK_s #x0073) 953 | (define XK_t #x0074) 954 | (define XK_u #x0075) 955 | (define XK_v #x0076) 956 | (define XK_w #x0077) 957 | (define XK_x #x0078) 958 | (define XK_y #x0079) 959 | (define XK_z #x007a) 960 | (define XK_braceleft #x007b) 961 | (define XK_bar #x007c) 962 | (define XK_braceright #x007d) 963 | (define XK_asciitilde #x007e) 964 | 965 | (define XK_nobreakspace #x00a0) 966 | (define XK_exclamdown #x00a1) 967 | (define XK_cent #x00a2) 968 | (define XK_sterling #x00a3) 969 | (define XK_currency #x00a4) 970 | (define XK_yen #x00a5) 971 | (define XK_brokenbar #x00a6) 972 | (define XK_section #x00a7) 973 | (define XK_diaeresis #x00a8) 974 | (define XK_copyright #x00a9) 975 | (define XK_ordfeminine #x00aa) 976 | (define XK_guillemotleft #x00ab) 977 | (define XK_notsign #x00ac) 978 | (define XK_hyphen #x00ad) 979 | (define XK_registered #x00ae) 980 | (define XK_macron #x00af) 981 | (define XK_degree #x00b0) 982 | (define XK_plusminus #x00b1) 983 | (define XK_twosuperior #x00b2) 984 | (define XK_threesuperior #x00b3) 985 | (define XK_acute #x00b4) 986 | (define XK_mu #x00b5) 987 | (define XK_paragraph #x00b6) 988 | (define XK_periodcentered #x00b7) 989 | (define XK_cedilla #x00b8) 990 | (define XK_onesuperior #x00b9) 991 | (define XK_masculine #x00ba) 992 | (define XK_guillemotright #x00bb) 993 | (define XK_onequarter #x00bc) 994 | (define XK_onehalf #x00bd) 995 | (define XK_threequarters #x00be) 996 | (define XK_questiondown #x00bf) 997 | (define XK_Agrave #x00c0) 998 | (define XK_Aacute #x00c1) 999 | (define XK_Acircumflex #x00c2) 1000 | (define XK_Atilde #x00c3) 1001 | (define XK_Adiaeresis #x00c4) 1002 | (define XK_Aring #x00c5) 1003 | (define XK_AE #x00c6) 1004 | (define XK_Ccedilla #x00c7) 1005 | (define XK_Egrave #x00c8) 1006 | (define XK_Eacute #x00c9) 1007 | (define XK_Ecircumflex #x00ca) 1008 | (define XK_Ediaeresis #x00cb) 1009 | (define XK_Igrave #x00cc) 1010 | (define XK_Iacute #x00cd) 1011 | (define XK_Icircumflex #x00ce) 1012 | (define XK_Idiaeresis #x00cf) 1013 | (define XK_ETH #x00d0) 1014 | (define XK_Eth #x00d0) 1015 | (define XK_Ntilde #x00d1) 1016 | (define XK_Ograve #x00d2) 1017 | (define XK_Oacute #x00d3) 1018 | (define XK_Ocircumflex #x00d4) 1019 | (define XK_Otilde #x00d5) 1020 | (define XK_Odiaeresis #x00d6) 1021 | (define XK_multiply #x00d7) 1022 | (define XK_Oslash #x00d8) 1023 | (define XK_Ooblique #x00d8) 1024 | (define XK_Ugrave #x00d9) 1025 | (define XK_Uacute #x00da) 1026 | (define XK_Ucircumflex #x00db) 1027 | (define XK_Udiaeresis #x00dc) 1028 | (define XK_Yacute #x00dd) 1029 | (define XK_THORN #x00de) 1030 | (define XK_Thorn #x00de) 1031 | (define XK_ssharp #x00df) 1032 | (define XK_agrave #x00e0) 1033 | (define XK_aacute #x00e1) 1034 | (define XK_acircumflex #x00e2) 1035 | (define XK_atilde #x00e3) 1036 | (define XK_adiaeresis #x00e4) 1037 | (define XK_aring #x00e5) 1038 | (define XK_ae #x00e6) 1039 | (define XK_ccedilla #x00e7) 1040 | (define XK_egrave #x00e8) 1041 | (define XK_eacute #x00e9) 1042 | (define XK_ecircumflex #x00ea) 1043 | (define XK_ediaeresis #x00eb) 1044 | (define XK_igrave #x00ec) 1045 | (define XK_iacute #x00ed) 1046 | (define XK_icircumflex #x00ee) 1047 | (define XK_idiaeresis #x00ef) 1048 | (define XK_eth #x00f0) 1049 | (define XK_ntilde #x00f1) 1050 | (define XK_ograve #x00f2) 1051 | (define XK_oacute #x00f3) 1052 | (define XK_ocircumflex #x00f4) 1053 | (define XK_otilde #x00f5) 1054 | (define XK_odiaeresis #x00f6) 1055 | (define XK_division #x00f7) 1056 | (define XK_oslash #x00f8) 1057 | (define XK_ooblique #x00f8) 1058 | (define XK_ugrave #x00f9) 1059 | (define XK_uacute #x00fa) 1060 | (define XK_ucircumflex #x00fb) 1061 | (define XK_udiaeresis #x00fc) 1062 | (define XK_yacute #x00fd) 1063 | (define XK_thorn #x00fe) 1064 | (define XK_ydiaeresis #x00ff) 1065 | 1066 | ) -------------------------------------------------------------------------------- /xlib/util.sls: -------------------------------------------------------------------------------- 1 | 2 | (library (psilab xlib util) 3 | 4 | (export x-query-pointer 5 | x-query-pointer-info-root 6 | x-query-pointer-info-child 7 | x-query-pointer-info-root-x 8 | x-query-pointer-info-root-y 9 | x-query-pointer-info-win-x 10 | x-query-pointer-info-win-y 11 | x-query-pointer-info-mask) 12 | 13 | (import (rnrs) 14 | (ypsilon c-types) 15 | (psilab xlib ffi)) 16 | 17 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 18 | 19 | (define-record-type x-query-pointer-info 20 | (fields root child root-x root-y win-x win-y mask)) 21 | 22 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 23 | 24 | (define (x-query-pointer dpy win) 25 | 26 | (let ((root-return (make-bytevector 4 0)) 27 | (child-return (make-bytevector 4 0)) 28 | (root-x-return (make-bytevector 4 0)) 29 | (root-y-return (make-bytevector 4 0)) 30 | (win-x-return (make-bytevector 4 0)) 31 | (win-y-return (make-bytevector 4 0)) 32 | (mask-return (make-bytevector 4 0))) 33 | 34 | (XQueryPointer dpy win 35 | root-return 36 | child-return 37 | root-x-return 38 | root-y-return 39 | win-x-return 40 | win-y-return 41 | mask-return) 42 | 43 | (make-x-query-pointer-info (bytevector-c-uint32-ref root-return 0) 44 | (bytevector-c-uint32-ref child-return 0) 45 | (bytevector-c-int32-ref root-x-return 0) 46 | (bytevector-c-int32-ref root-y-return 0) 47 | (bytevector-c-int32-ref win-x-return 0) 48 | (bytevector-c-int32-ref win-y-return 0) 49 | (bytevector-c-uint32-ref mask-return 0)))) 50 | 51 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 52 | 53 | ) -------------------------------------------------------------------------------- /xlib/util/x-fetch-name.sls: -------------------------------------------------------------------------------- 1 | 2 | (library (psilab xlib util x-fetch-name) 3 | 4 | (export x-fetch-name) 5 | 6 | (import (rnrs) 7 | (ypsilon c-types) 8 | (psilab xlib ffi)) 9 | 10 | (define x-fetch-name 11 | (let ((bv (make-bytevector sizeof:void*))) 12 | (lambda (dpy id) 13 | (if (= (XFetchName dpy id bv) 0) 14 | #f 15 | (let ((name (c-string-ref (bytevector-c-void*-ref bv 0)))) 16 | (XFree (bytevector-c-void*-ref bv 0)) 17 | name))))) 18 | 19 | ) -------------------------------------------------------------------------------- /xlib/util/x-get-geometry.sls: -------------------------------------------------------------------------------- 1 | 2 | (library (psilab xlib util x-get-geometry) 3 | 4 | (export x-get-geometry 5 | x-get-geometry-info-root 6 | x-get-geometry-info-x 7 | x-get-geometry-info-y 8 | x-get-geometry-info-width 9 | x-get-geometry-info-height 10 | x-get-geometry-info-border-width 11 | x-get-geometry-info-depth) 12 | 13 | (import (rnrs) 14 | (ypsilon ffi) 15 | (psilab xlib ffi)) 16 | 17 | (define-record-type x-get-geometry-info 18 | (fields root x y width height border-width depth)) 19 | 20 | (define (x-get-geometry dpy id) 21 | 22 | (let ((root (make-bytevector 4 0)) 23 | (x (make-bytevector 4 0)) 24 | (y (make-bytevector 4 0)) 25 | (width (make-bytevector 4 0)) 26 | (height (make-bytevector 4 0)) 27 | (border-width (make-bytevector 4 0)) 28 | (depth (make-bytevector 4 0))) 29 | 30 | (XGetGeometry dpy id root x y width height border-width depth) 31 | 32 | (make-x-get-geometry-info (bytevector-c-uint32-ref root 0) 33 | (bytevector-c-int32-ref x 0) 34 | (bytevector-c-int32-ref y 0) 35 | (bytevector-c-uint32-ref width 0) 36 | (bytevector-c-uint32-ref height 0) 37 | (bytevector-c-uint32-ref border-width 0) 38 | (bytevector-c-uint32-ref depth 0)))) 39 | 40 | ) 41 | -------------------------------------------------------------------------------- /xlib/util/x-query-tree.sls: -------------------------------------------------------------------------------- 1 | 2 | (library (psilab xlib util x-query-tree) 3 | 4 | (export x-query-tree 5 | x-query-tree-info-root 6 | x-query-tree-info-parent 7 | x-query-tree-info-children) 8 | 9 | (import (rnrs) 10 | (ypsilon ffi) 11 | (psilab xlib ffi)) 12 | 13 | (define-record-type x-query-tree-info 14 | (fields root parent children)) 15 | 16 | (define (x-query-tree dpy id) 17 | 18 | (let ((root (make-bytevector 4)) 19 | (parent (make-bytevector 4)) 20 | (children (make-bytevector sizeof:void*)) 21 | (nchildren (make-bytevector 4))) 22 | 23 | (XQueryTree dpy id root parent children nchildren) 24 | 25 | (let ((root (bytevector-u32-native-ref root 0)) 26 | (parent (bytevector-u32-native-ref parent 0)) 27 | (children-addr (bytevector-c-void*-ref children 0)) 28 | (nchildren (bytevector-u32-native-ref nchildren 0))) 29 | 30 | (let ((children-bv (make-bytevector-mapping children-addr 31 | (* nchildren 4)))) 32 | 33 | (let ((children 34 | (let loop ((i 0)) 35 | (if (>= i nchildren) 36 | '() 37 | (cons (bytevector-u32-native-ref children-bv (* i 4)) 38 | (loop (+ i 1))))))) 39 | 40 | (XFree children-addr) 41 | 42 | (make-x-query-tree-info root parent children)))))) 43 | 44 | ) --------------------------------------------------------------------------------