common lisp 使用 cl-gtk4 使用各种小部件 demo

;;;; gtk4-laboratory.lisp —— 多个部件的完整演示
;;;; 运行: (ql:quickload :cl-gtk4)
;;;;       (load "gtk4-laboratory.lisp")
;;;;       (gtk4-laboratory:gtk4-laboratory)

(ql:quickload :cl-gtk4)

(defpackage #:gtk4-laboratory
  (:use #:cl #:gtk4)
  (:export #:gtk4-laboratory))

(in-package #:gtk4-laboratory)

;;; ================= 状态与工具 =================

(defvar *status-label* nil)

(defun update-status (text)
  (when *status-label*
    (setf (label-text *status-label*) text)))

(defun section-label (markup)
  (let ((label (make-label :str markup)))
    (setf (label-use-markup-p label) t
          (widget-halign label) +align-start+)
    label))

(defun set-margins (w n)  
  (setf (widget-margin-top w) n
        (widget-margin-bottom w) n
        (widget-margin-start w) n
        (widget-margin-end w) n))

(defun make-hbox (spacing)
  (make-box :orientation +orientation-horizontal+ :spacing spacing))

(defun make-vbox (spacing)
  (make-box :orientation +orientation-vertical+ :spacing spacing))

;;; ================= 选项卡 1: 基础部件 =================

(defun make-basics-tab ()
  (let ((vbox (make-vbox 8)))
    (set-margins vbox 12)

    ;; --- Label + Pango ---
    (box-append vbox (section-label "<b>1. Label + Pango 标记</b>"))
    (let ((hbox (make-hbox 8)))
      (dolist (m '("<b>粗体</b>" "<i>斜体</i>"
                   "<span foreground='red'>红色</span>"
                   "<span font='24'>大字体</span>"))
        (let ((l (make-label :str m)))
          (setf (label-use-markup-p l) t)
          (box-append hbox l)))
      (box-append vbox hbox))

    ;; --- Button / ToggleButton ---
    (box-append vbox (section-label "<b>2. Button 与 ToggleButton</b>"))
    (let ((hbox (make-hbox 8))
          (count 0))
      (let ((btn (make-button :label "点击计数: 0")))
        (connect btn "clicked"
                 (lambda (b)
                   (declare (ignore b))
                   (update-status (format nil "按钮点击了 ~A 次" (incf count)))
                   (setf (button-label btn) (format nil "点击计数: ~A" count))))
        (box-append hbox btn))
      (let ((tg (make-toggle-button :label "切换: 关")))
        (connect tg "toggled"
                 (lambda (b)
                   (setf (button-label b)
                         (format nil "切换: ~A"
                                 (if (toggle-button-active-p b) "开" "关")))))
        (box-append hbox tg))
      (let ((icon (make-button :label "带图标的按钮")))
        (setf (button-icon-name icon) "applications-graphics") ; ⚠C 若报错删此行
        (box-append hbox icon))
      (box-append vbox hbox))

    ;; --- CheckButton 组（套在 Frame 里）---
    (box-append vbox (section-label "<b>3. CheckButton 复选框</b>"))
    (let ((frame (make-frame :label "选项"))         
          (vbox-checks (make-vbox 4))
          (states '(:a nil :b t :c nil))
          (summary (make-label :str "已选择: --")))
      (dolist (opt '(:a :b :c))
        (let ((check (make-check-button
                       :label (ecase opt
                                (:a "选项 A - 功能 X")
                                (:b "选项 B - 功能 Y")
                                (:c "选项 C - 功能 Z")))))
          (setf (check-button-active-p check) (getf states opt))
          (connect check "toggled"
                   (lambda (b)
                     (setf (getf states opt) (check-button-active-p b))
                     (let ((sel (loop :for o :in '(:a :b :c)
                                      :when (getf states o) :collect o)))
                       (setf (label-text summary)
                             (format nil "已选择: ~{~A~^, ~}" (or sel '("无")))))))
          (box-append vbox-checks check)))
      (box-append vbox-checks summary)
      (setf (frame-child frame) vbox-checks)           
      (box-append vbox frame))

    ;; --- Switch ---
    (box-append vbox (section-label "<b>4. Switch 开关</b>"))
    (let ((hbox (make-hbox 12))
          (switch-label (make-label :str "夜间模式: 关"))
          (sw (make-switch)))
      (setf (widget-valign sw) +align-center+)
      ;; notify:: 信号会额外传一个 GParamSpec 参数，
      ;; 用 &rest 吸收多余实参，避免参数数量不匹配的运行时错误
      (connect sw "notify::active"
               (lambda (w &rest rest)
                 (declare (ignore w rest))
                 (setf (label-text switch-label)
                       (format nil "夜间模式: ~A"
                               (if (switch-active-p sw) "开启" "关闭")))
                 (update-status (format nil "夜间模式已~A"
                                        (if (switch-active-p sw) "开启" "关闭")))))
      (box-append hbox (make-label :str "切换夜间模式:"))
      (box-append hbox sw)
      (box-append hbox switch-label)
      (box-append vbox hbox))

    vbox))

;;; ================= 选项卡 2: 文本输入 =================

(defun make-input-tab ()
  (let ((vbox (make-vbox 8))
        (entry (make-entry))
        (mirror (make-label :str "（输入内容同步显示在这里）")))
    (set-margins vbox 12)

    ;; --- Entry ---
    (box-append vbox (section-label "<b>1. Entry 单行输入</b>"))
    (setf (entry-placeholder-text entry) "在此输入…"
          (widget-hexpand-p entry) t)
    (connect entry "changed"
             (lambda (e)
               (declare (ignore e))
               (setf (label-text mirror) (entry-buffer-text entry))))
    (connect entry "activate"
             (lambda (e)
               (declare (ignore e))
               (update-status (format nil "Entry 确认: ~A" (entry-buffer-text entry)))))
    (box-append vbox entry)
    (box-append vbox mirror)

    (box-append vbox (make-separator :orientation +orientation-horizontal+))

    ;; --- TextView ---
    (box-append vbox (section-label "<b>2. TextView 多行编辑</b>"))
    (let* ((scrolled (make-scrolled-window))
           (text-view (make-text-view))
           (buffer (text-view-buffer text-view)))
      (setf (widget-hexpand-p scrolled) t
            (widget-vexpand-p scrolled) t
            (scrolled-window-child scrolled) text-view)
      (setf (text-buffer-text buffer)          
            "在这里编辑文本。
（buffer 读写的 API 形态请对照官方 simple-text-view 示例）")
      (box-append vbox scrolled)
      (let ((hbox (make-hbox 8))
            (clear (make-button :label "清空")))
        (connect clear "clicked"
                 (lambda (b)
                   (declare (ignore b))
                   (setf (text-buffer-text buffer) "")
                   (update-status "文本已清空")))
        (box-append hbox clear)
        (box-append vbox hbox)))

    vbox))


(defun make-list-view-tab (items)
  "ListView —— 绕开 GIR 静态类型陷阱的版本。
   不再连接 setup，也不再读回 child：
   每次绑定时直接创建带数据的 Label 并设为 child。"
  (let* ((model (make-string-list :strings items))
         (factory (make-signal-list-item-factory))
         (selection (make-single-selection :model model))
         (view (make-list-view :model selection :factory factory)))
    (connect factory "bind"
             (lambda (f item &rest rest)
               (declare (ignore f rest))
               (setf (list-item-child item)
                     (make-label :str (nth (list-item-position item) items)))))
    view))


(defun make-lists-tab ()
  (let ((vbox (make-vbox 8))
        (strings '("苹果 Apple" "香蕉 Banana" "樱桃 Cherry"
                   "葡萄 Grape" "柠檬 Lemon")))
    (set-margins vbox 12)

    ;; --- DropDown（无需自定义 factory，StringList 默认即显示字符串）---
    (box-append vbox (section-label "<b>1. DropDown 下拉选择</b>"))
    (let ((hbox (make-hbox 8))
          (dd (make-drop-down :strings strings))
          (choice (make-label :str "选择: —")))
      ;; (setf (drop-down-model dd) (make-string-list :strings strings))
      (connect dd "notify::selected"
               (lambda (w &rest rest)
                 (declare (ignore w rest))
                 (let ((i (drop-down-selected dd)))
                   (setf (label-text choice)
                         (format nil "选择: ~A" (nth i strings))))))
      (box-append hbox (make-label :str "水果:"))
      (box-append hbox dd)
      (box-append hbox choice)
      (box-append vbox hbox))

    ;; --- ListView ---
    (box-append vbox (section-label "<b>2. ListView 列表视图</b>"))
    (let ((scrolled (make-scrolled-window))
          (view (make-list-view-tab
                 (loop :for i :from 1 :to 20
                       :collect (format nil "项目 ~2D - 列表示例" i)))))
      (setf (widget-vexpand-p scrolled) t
            (scrolled-window-child scrolled) view)
      (box-append vbox scrolled))

    vbox))

;;; ================= 选项卡 4: 进度与动画 =================
(defun make-progress-tab ()
  (let ((vbox (make-vbox 8))
        (bar (make-progress-bar))
        (spinner (make-spinner))
        (pct (make-label :str "进度: 0%"))
        (revealer (make-revealer))
        (progress 0.0))
    (set-margins vbox 12)
    (box-append vbox (section-label "<b>ProgressBar + Spinner + Revealer</b>"))
    (box-append vbox pct)
    (box-append vbox bar)
    (box-append vbox spinner)
    (let ((done (make-label :str "<b>🎉 演示完成！</b>")))
      (setf (label-use-markup-p done) t)
      (setf (revealer-child revealer) done))
    (box-append vbox revealer)

    (let ((btn (make-button :label "前进一步 (+10%)")))
      (connect btn "clicked"
               (lambda (b)
                 (declare (ignore b))
                 (setf progress (min 1.0 (+ progress 0.1)))
                 (setf (progress-bar-fraction bar) progress
                       (spinner-spinning-p spinner) (< progress 1.0)
                       (label-text pct)
                       (format nil "进度: ~D%" (round (* 100 progress))))
                 (when (>= progress 1.0)
                   (setf (revealer-reveal-child-p revealer) t)
                   (update-status "演示完成！"))))
      (box-append vbox btn))
    (let ((btn2 (make-button :label "重置")))
      (connect btn2 "clicked"
               (lambda (b)
                 (declare (ignore b))
                 (setf progress 0.0
                       (progress-bar-fraction bar) 0.0
                       (spinner-spinning-p spinner) nil
                       (revealer-reveal-child-p revealer) nil
                       (label-text pct) "进度: 0%")))
      (box-append vbox btn2))
    vbox))

;;; ================= 入口（骨架逐字来自官方 simple-counter）=================

(define-application (:name gtk4-laboratory
                     :id "org.example.gtk4-laboratory")
  (define-main-window (window (make-application-window :application *application*))
    (setf (window-title window) "GTK4 Widget Laboratory"
          (window-default-size window) (list 800 800))
    (let ((notebook (make-notebook))
          (outer (make-box :orientation +orientation-vertical+
                           :spacing 6)))
      (notebook-append-page notebook (make-basics-tab)
                            (make-label :str "基础"))
      (notebook-append-page notebook (make-input-tab)
                            (make-label :str "输入"))
      (notebook-append-page notebook (make-lists-tab)
                            (make-label :str "列表"))
      (notebook-append-page notebook (make-progress-tab)
                            (make-label :str "进度"))
      (setf *status-label* (make-label :str "就绪 — 操作任意部件试试"))
      (box-append outer notebook)
      (box-append outer *status-label*)
      (setf (window-child window) outer))
    (window-present window)))

 (gtk4-laboratory:gtk4-laboratory)

common lisp 使用 cl-gtk4 使用各种小部件 demo

效果图如下：