wig

wig.scm (12261B)

---

 ;;; Wig --- Widgets in Guile
 ;;; Copyright © 2026 Luke Willis <lukejw@monastech.xyz>
 ;;;
 ;;; This file is part of Wig.
 ;;; 
 ;;; Wig is free software: you can redistribute it and/or modify it under
 ;;; the terms of the GNU General Public License as published by the Free
 ;;; Software Foundation, either version 3 of the License, or (at your option)
 ;;; any later version.
 ;;; 
 ;;; Wig is distributed in the hope that it will be useful, but WITHOUT
 ;;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
 ;;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
 ;;; for more details.
 ;;; 
 ;;; You should have received a copy of the GNU General Public License along
 ;;; with Wig. If not, see <https://www.gnu.org/licenses/>.
 
 (define-module (wig)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
   #:use-module (ice-9 match)
   #:use-module (system foreign)
   #:use-module (rnrs bytevectors)
   #:export (widget
             widget?
             widget-hexpand
             widget-vexpand
             widget-width
             widget-height
             widget-contents
             
             anchors
             anchors?
             anchors-top
             anchors-bottom
             anchors-left
             anchors-right
             
             window
             window?
             window-label
             window-anchors
             window-width
             window-height
             
             configuration
             configuration?
             configuration-windows))
 
 ;; Widget-related records
 
 (define-record-type <widget>
   (make-widget ghost valign hexpand vexpand width height margin color contents)
   widget?
   (ghost widget-ghost)
   (valign widget-valign)
   (hexpand widget-hexpand)
   (vexpand widget-vexpand)
   (width widget-width)
   (height widget-height)
   (margin widget-margin)
   (color widget-color)
   (contents widget-contents))
 
 (define (widgets-predict-layout widgets)
   "Find the minimum width to contain a list of widgets."
   (let loop ((queue widgets)
              (prev #f)
              (reserved 0)
              (slots 0))
     (if (null? queue)
       (cons slots (+ reserved prev))
       (let* ((current (car queue))
              (width (widget-width current))
              (height (widget-height current))
              (margin (widget-margin current)))
         (if (widget-hexpand current)
           (loop (cdr queue)
                 margin
                 (+ reserved (max (or prev 0) margin))
                 (+ slots 1))
           (loop (cdr queue)
                 margin
                 (+ reserved (max (or prev 0) margin) width)
                 slots))))))
 
 (define* (widget #:key
                  (ghost #f)
                  (valign #t)
                  (hexpand #f)
                  (vexpand #f)
                  (width 0)
                  (height 0)
                  (margin 0)
                  (color #xFF00FF)
                  (contents #f))
   (make-widget ghost
                valign
                hexpand
                vexpand
                ;; Expand to fit children if too small
                (if (list? contents)
                  (match (widgets-predict-layout contents)
                    ((slots . reserved)
                     (if (< width reserved)
                       reserved
                       width)))
                  width)
                (if (list? contents)
                  (fold (lambda (in out)
                          (max out (+ (widget-height in)
                                      (* (widget-margin in) 2))))
                        height
                        contents)
                  height)
                margin
                color
                contents))
 
 ;; Window-related records
 
 (define-record-type <anchors>
   (make-anchors top bottom left right)
   anchors?
   (top anchors-top)
   (bottom anchors-bottom)
   (left anchors-left)
   (right anchors-right))
 
 (define* (anchors #:key
                   (top #f)
                   (bottom #f)
                   (left #f)
                   (right #f))
   (unless (and (boolean? top)
                (boolean? bottom)
                (boolean? left)
                (boolean? right))
     (error "Invalid anchors!"))
   (make-anchors top bottom left right))
 
 (define-record-type <window>
   (make-window label anchors exclusive width height margin widgets)
   window?
   (label window-label)
   (anchors window-anchors)
   (exclusive window-exclusive)
   (width window-width)
   (height window-height)
   (margin window-margin)
   (widgets window-widgets))
 
 (define* (window #:key
                  (label "wig_window")
                  (anchors (anchors))
                  (exclusive #f)
                  (width 0)
                  (height 0)
                  (margin 0)
                  (widgets (list (widget #:hexpand #t
                                         #:vexpand #t
                                         #:width 0
                                         #:height 0
                                         #:color #xFFFFFF))))
   (unless (and (string? label)
                (anchors? anchors)
                (boolean? exclusive)
                (integer? width)
                (integer? height)
                (integer? margin)
                (list? widgets)
                (every widget? widgets))
     (error "Invalid window!"))
   (when (and (anchors-top anchors)
              (anchors-bottom anchors)
              (anchors-left anchors)
              (anchors-right anchors)
              exclusive)
     (error "A window cannot anchor to all sides and be exclusive."))
   (make-window label anchors exclusive width height margin widgets))
 
 (define-record-type <configuration>
   (make-configuration font windows)
   configuration?
   (font configuration-font)
   (windows configuration-windows))
 
 (define* (configuration #:key
                         (font "monospace:size=14")
                         (windows '()))
   (unless (and (string? font)
                (list? windows)
                (every window? windows))
     (error "Invalid configuration!"))
   (make-configuration font windows))
 
 ;; Private compilation types/functions
 
 (define-record-type <region>
   (make-region x y width height)
   region?
   (x region-x)
   (y region-y)
   (width region-width)
   (height region-height))
 
 (define* (region #:key
                  x
                  y
                  width
                  height)
   (make-region x y width height))
 
 (define (count-widgets widgets)
   "Return the total number of widgets in a tree of widgets."
   (cond ((pair? widgets)
          (+ (count-widgets (car widgets))
             (count-widgets (cdr widgets))))
         ((widget? widgets)
          (+ 1 (count-widgets (widget-contents widgets))))
         (else 0)))
 
 
 (define (flatten-widgets widgets container)
   (let* ((data (widgets-predict-layout widgets))
          (slots (car data))
          (reserved (cdr data))
          (slot-width (if (> slots 0)
                        (/ (- (region-width container) reserved)
                           slots)
                        0)))
     (let loop ((queue widgets)
                (x (region-x container))
                (y (region-y container))
                (prev #f)
                (result '()))
       (if (null? queue)
         result
         (let* ((current (car queue))
                (margin (widget-margin current))
                (width (if (widget-hexpand current)
                         slot-width
                         (widget-width current)))
                (height (if (widget-vexpand current)
                          (- (region-height container)
                             (* margin 2))
                          (widget-height current)))
                (nx (+ x (max (or prev 0) margin)))
                (ny (+ y
                       (if (and (not (widget-vexpand current))
                                (widget-valign current))
                         (- (/ (region-height container) 2)
                            (/ height 2))
                         margin) ))
                )
           (loop (cdr queue)
                 (+ nx width)
                 y
                 margin
                 (cons (cons current
                             (region #:x nx
                                     #:y ny
                                     #:width width
                                     #:height height))
                       result)))))))
 
 (define (flatten-widgets-old widgets reg)
   "Fit a list of widgets inside a region, returning widget/region pairs."
   (let* ((data (fold (lambda (input output)
                        (if (widget-hexpand input)
                          (cons (+ (car output) 1)
                                (cdr output))
                          (cons (car output)
                                (+ (cdr output)
                                   (widget-width input)
                                   (* (widget-margin input) 2)))))
                      '(0 . 0)
                      widgets))
          (num-hexpand (car data))
          (reserved-width (cdr data))
          (hexpand-size (if (> num-hexpand 0)
                          (/ (- (region-width reg) reserved-width)
                             num-hexpand)
                          0)))
     (let loop ((queue widgets)
                (result '())
                (x (region-x reg))
                (y (region-y reg)))
       (if (null? queue)
         result
         (let* ((widget (car queue))
                (width (if (widget-hexpand widget)
                         hexpand-size
                         (widget-width widget)))
                (height (if (widget-vexpand widget)
                          (region-height reg)
                          (widget-height widget))))
           (loop (cdr queue)
                 (cons (cons widget
                             (region #:x (+ x (widget-margin widget))
                                     #:y (+ y (if (and (not (widget-vexpand widget))
                                                  (widget-valign widget))
                                           (- (/ (region-height reg) 2)
                                              (/ height 2))
                                           0))
                                     #:width width
                                     #:height height))
                       result)
                 (+ x width (* (widget-margin widget) 2))
                 y))))))
 
 ;; TODO: Look into using bstructs
 
 (define (bools-to-bitflags bools)
   (fold (lambda (in out)
           (+ (if in 1 0)
              (ash out 1)))
     0
     bools))
 
 (define (compile-widgets widgets width height bv)
   "Fit a tree of widgets into a region, writing results into a bytevector."
   (let loop ((queue (flatten-widgets widgets
                                      (region #:x 0
                                              #:y 0
                                              #:width width
                                              #:height height)))
              (result '())
              (index 0))
     (if (null? queue)
       result
       (let* ((current (car queue))
              (widget (car current))
              (region (cdr current)))
         ;; struct wig_widget {
         ;;     uint32_t x;
         ;.     uint32_t y;
         ;;     uint32_t width;
         ;;     uint32_t height;
         ;;     uint32_t color;
         ;;     uint32_t flags;
         ;; }
         (bytevector-u32-native-set! bv (+ index (* 4 0)) (region-x region))
         (bytevector-u32-native-set! bv (+ index (* 4 1)) (region-y region))
         (bytevector-u32-native-set! bv (+ index (* 4 2)) (region-width region))
         (bytevector-u32-native-set! bv (+ index (* 4 3)) (region-height region))
         (bytevector-u32-native-set! bv (+ index (* 4 4)) (widget-color widget))
         (bytevector-u32-native-set! bv (+ index (* 4 5))
                                        (bools-to-bitflags
                                         (list
                                          (widget-ghost widget))))
         ;; Iterate
         (loop (if (list? (widget-contents widget))
                 (append (flatten-widgets (widget-contents widget)
                                          region)
                         (cdr queue))
                 (cdr queue))
               (cons region result)
               (+ index (* 4 6)))))))