From f43df41218b6d2de2faf556d4295e1f351fa044d Mon Sep 17 00:00:00 2001 From: Hans Dijkema Date: Wed, 6 Aug 2025 09:37:29 +0200 Subject: [PATCH] Initial --- info.rkt | 22 +++++++ main.rkt | 112 +++++++++++++++++++++++++++++++++ scribblings/columns-pane.scrbl | 64 +++++++++++++++++++ 3 files changed, 198 insertions(+) create mode 100644 info.rkt create mode 100644 main.rkt create mode 100644 scribblings/columns-pane.scrbl diff --git a/info.rkt b/info.rkt new file mode 100644 index 0000000..19326f8 --- /dev/null +++ b/info.rkt @@ -0,0 +1,22 @@ +#lang info + +(define pkg-authors '(hnmdijkema)) +(define version "0.1") +(define license 'Apache-2.0) +(define collection "columns-pane") +(define pkg-desc "A pane that arranges it's children widgets in columns") + +(define scribblings + '( + ("scribblings/columns-pane.scrbl" () (library) "columns-pane%") + ) + ) + +(define deps + '("racket/gui")) + +(define build-deps + '("racket-doc" + "rackunit-lib" + "scribble-lib")) + diff --git a/main.rkt b/main.rkt new file mode 100644 index 0000000..042240a --- /dev/null +++ b/main.rkt @@ -0,0 +1,112 @@ +#lang racket + +(require racket/gui) + +(provide columns-pane%) + +(define columns-pane% + (class vertical-pane% + (super-new) + + ;; Internal data + (define hpanes #f) + (define creating-row #f) + (define current-col 0) + (define current-row 0) + + (define/private (mk-hpane*) + (set! creating-row #t) + (let ((new-pane (new horizontal-pane% [parent this] + [spacing spacing] [horiz-margin horiz-margin] [vert-margin (round (/ spacing 2))] + [stretchable-height #f]))) + (set! creating-row #f) + new-pane) + ) + + (define/private (get-row* i) + (when (eq? hpanes #f) + (set! hpanes (make-vector (+ i 1) #f))) + (when (>= i (vector-length hpanes)) + (let ((v hpanes)) + (set! hpanes (make-vector (+ i 1) #f)) + (vector-copy! hpanes 0 v))) + (let ((p (vector-ref hpanes i))) + (when (eq? p #f) + (set! p (mk-hpane*)) + (vector-set! hpanes i p)) + p)) + + (define/private (child* c r) + (let* ((hpane (vector-ref hpanes r)) + (children (send hpane get-children)) + (child (if (>= c (length children)) #f (list-ref children c))) + ) + child)) + + (define/private (max-width* c r w) + (if (< r (vector-length hpanes)) + (let* ((child (child* c r)) + (child-width (if (eq? child #f) 0 (send child get-width)))) + (max-width* c (+ r 1) (if (> child-width w) child-width w))) + w)) + + (define/private (set-min-width* c r w) + (when (< r (vector-length hpanes)) + (let ((child (child* c r))) + (when (not (eq? child #f)) + (send child min-width w)) + (set-min-width* c (+ r 1) w)))) + + (define/private (arrange-col* c) + (let ((w (max-width* c 0 -1))) + (set-min-width* c 0 w))) + + (define/private (arrange*) + (letrec ((cols (length (send (vector-ref hpanes 0) get-children))) + (f (lambda (c) + (when (< c cols) + (arrange-col* c) + (f (+ c 1))))) + ) + (f 0))) + + ;; Fields that can be given + (init-field [vert-margin 5] [horiz-margin 5] [spacing 5] [columns 1]) + + ;; Public methods + (define/override (after-new-child child) + (super after-new-child child) + (when (eq? creating-row #f) + (let ((hpane (get-row* current-row))) + (send child reparent hpane) + (set! current-col (+ current-col 1)) + (when (>= current-col columns) + (set! current-row (+ current-row 1)) + (set! current-col 0)) + ))) + + (define/override (place-children info width height) + (let ((r (super place-children info width height))) + (arrange*) + r + )) + + )) + + +;;; GUI Testing + +;(define win (new frame% [label "Hi there!"])) +;(define grid-group (new group-box-panel% [label "My group"] [parent win] [horiz-margin 10] [vert-margin 10])) + +;(define g (new columns-pane% [parent grid-group] [columns 3])) + +;(define btn1 (new button% [parent g] [label "Button 1"])) +;(define g1 (new gauge% [parent g] [stretchable-width #t] [label "gauge 1"] [range 100])) +;(define lbl1 (new message% [parent g] [label "This is lbl 1"])) + +;(define btn2 (new button% [parent g] [label "Btn 2"])) +;(define lbl2 (new message% [parent g] [label "This is lbl 2"])) + +;(send win show #t) + diff --git a/scribblings/columns-pane.scrbl b/scribblings/columns-pane.scrbl new file mode 100644 index 0000000..f476139 --- /dev/null +++ b/scribblings/columns-pane.scrbl @@ -0,0 +1,64 @@ +#lang scribble/manual + +@(require + scribble/example + (for-label racket/base + racket/string + racket/file)) + +(define myeval + (make-base-eval '(require columns-pane))) + +@title[#:tag "columns pane"]{Arrange widgets in columns and make them of equal width per column} + +@author[@author+email["Hans Dijkema" "hans@dijkewijk.nl"]] + +@defmodule[columns-pane]{This module provides a new class @racket[columns-pane%] that can be used to arrange widgets in a table like fashon, making all widgets in a column of the same width} + +@defclass/title[columns-pane% vertical-pane% ()]{ + +A columns pane arranges its subwindows in columns. The number of columns must be given in advance and initializes to 1. + +@defconstructor[([parent (or/c (is-a?/c frame%) (is-a?/c dialog%) + (is-a?/c panel%) (is-a?/c pane%))] + [columns 1] + [vert-margin spacing-integer? 0] + [horiz-margin spacing-integer? 0] + [border spacing-integer? 0] + [spacing spacing-integer? 0] + [alignment (list/c (or/c 'left 'center 'right) + (or/c 'top 'center 'bottom)) + '(left center)] + [min-width (or/c dimension-integer? #f) #f] + [min-height (or/c dimension-integer? #f) #f] + [stretchable-width any/c #t] + [stretchable-height any/c #t])]{ + +}} + + +@#reader scribble/comment-reader +[racketblock + (require racket/gui) + (require columns-pane) + + (define win (new frame% [label "A new frame"])) + (define grid-group (new group-box-panel% + [label "A new group"] [parent win] [horiz-margin 10] [vert-margin 10])) + + ;; Adding the columns pane with 3 columns + (define g (new columns-pane% [parent grid-group] [columns 3])) + + (define btn1 (new button% [parent g] [label "Button 1"])) + (define g1 (new gauge% [parent g] [stretchable-width #t] [label "gauge 1"] [range 100])) + (define lbl1 (new message% [parent g] [label "This is lbl 1"])) + + (define btn2 (new button% [parent g] [label "Btn 2"])) + (define lbl2 (new message% [parent g] [label "This is lbl 2"])) + + ;; Now, when the window is shown, the columns pane will arrange it's children + ;; to have the same width in each column. + (send win show #t) +] + +