Browse files

Fix a bunch of crap related to UI, and especially text-field.

  • Loading branch information...
Shinmera committed Dec 17, 2017
1 parent 4a3688c commit 683d44deb97184614356ccc98aafc2a75f7145a3
Showing with 87 additions and 46 deletions.
  1. +7 −4 ui/elements.lisp
  2. +0 −11 ui/pane.lisp
  3. +71 −28 ui/text-field.lisp
  4. +1 −1 ui/ui-window.lisp
  5. +6 −0 ui/widget.lisp
  6. +2 −2 workbench.lisp
@@ -27,7 +27,7 @@
(change-class (make-rectangle (width widget) (height widget) :align :topleft)
'vertex-array :load T)))
(defmethod paint :around ((widget widget) target)
(defmethod paint :around ((widget flat-widget) target)
(with-pushed-matrix (((model-matrix) :identity))
(translate (vxy_ (extent widget)))
@@ -67,8 +67,11 @@
:font (asset 'trial 'trial::noto-sans)
:align (list :center :center)))
(defmethod initialize-instance :after ((text-element text-element) &key text text-color font)
(setf (text-asset text-element) (make-instance 'text :text text :color text-color :font font)))
(defmethod initialize-instance :after ((text-element text-element) &key (size 24) text text-color font)
(setf (text-asset text-element) (make-instance 'text :text text
:color text-color
:font font
:size size)))
(defmethod text ((text-element text-element))
(text (text-asset text-element)))
@@ -81,7 +84,7 @@
(destructuring-bind (halign valign) (align text-element)
(let* ((bounds (extent (text-asset text-element)))
(x (ecase halign
(:left (getf bounds :l))
(:left (- (getf bounds :l)))
(:right (- (+ (width text-element) (getf bounds :l)) (getf bounds :r)))
(:center (/ (- (+ (width text-element) (getf bounds :l)) (getf bounds :r)) 2))))
(y (ecase valign
@@ -63,14 +63,3 @@
(loop for e across (objects pane)
do (paint e target)))
(defclass rectangular-pane (pane)
(defmethod paint :around ((pane rectangular-pane) target)
(with-pushed-attribs ()
(let ((prev (gl:get-integer :scissor-box 4)))
(enable :scissor-test)
(with-vec4 (x y w h) (extent pane)
(gl:scissor x y w h))
(gl:scissor (aref prev 0) (aref prev 1) (aref prev 2) (aref prev 3)))))
@@ -6,12 +6,60 @@
(in-package #:org.shirakumo.fraf.trial.ui)
(define-shader-entity text-field-cursor (vertex-entity)
((text-field :initarg :text-field :accessor text-field)
(text-position :initform 0 :accessor text-position)
(cursor-size :initform (vec4 0 0 0.5 1) :reader cursor-size))
:text-field (error "TEXT-FIELD required.")
:vertex-array (asset 'trial 'fullscreen-square)))
(defmethod initialize-instance :after ((cursor text-field-cursor) &key text-field)
(let* ((extent (extent (text-asset text-field)))
(u (getf extent :t))
(b (getf extent :b)))
(setf (vy (cursor-size cursor)) 0)
(setf (vz (cursor-size cursor)) (/ (size (text-asset text-field))
(size (font (text-asset text-field)))
(setf (vw (cursor-size cursor)) (/ (- u b) 2))))
(defmethod (setf text-position) :around (value (cursor text-field-cursor))
(call-next-method (min (length (text (text-field cursor))) (max 0 value)) cursor))
(defmethod (setf text-position) :after (value (cursor text-field-cursor))
(setf (vx (cursor-size cursor))
(getf (text-extent (text-asset (text-field cursor))
(subseq (text (text-field cursor)) 0 (text-position cursor)))
(defmethod paint :before ((cursor text-field-cursor) target)
(let ((size (cursor-size cursor)))
(translate-by (vx size) (+ (vy size) (vw size)) 0)
(scale-by (vz size) (vw size) 1)))
(define-class-shader (text-field-cursor :fragment-shader)
"out vec4 color;
void main(){
color = vec4(0,0,0,1);
(define-shader-entity text-field (highlightable-widget text-element control)
((cursor :initform 0 :accessor cursor)
(vtext :initarg :text :accessor vtext))
((cursor :accessor cursor))
:align (list :left :center)))
(defmethod initialize-instance :after ((text-field text-field) &key)
(setf (cursor text-field) (make-instance 'text-field-cursor :text-field text-field))
(setf (text-position (cursor text-field)) (length (text text-field))))
(defmethod register-object-for-pass :after (pass (text-field text-field))
(register-object-for-pass pass (cursor text-field)))
(defmethod paint :after ((text-field text-field) target)
(paint (cursor text-field) target))
(defun string-remove-pos (string pos)
(let ((new (make-array (1- (length string)) :element-type 'character)))
(replace new string :end1 pos)
@@ -25,32 +73,27 @@
(replace new string :start1 (+ pos (length stuff)) :start2 pos)
;; This is fucking stupid. Do something more sensible.
(defmethod (setf cursor) :after (pos (text-field text-field))
(setf (text text-field) (string-insert-pos (vtext text-field) pos "|")))
(defmethod handle ((event key-release) (text-field text-field))
(let ((key (key event)))
(case key
(when (<= 1 (cursor text-field) (length (text text-field)))
(setf (vtext text-field) (string-remove-pos (vtext text-field) (1- (cursor text-field))))
(decf (cursor text-field))))
(when (< -1 (cursor text-field) (length (vtext text-field)))
(setf (vtext text-field) (string-remove-pos (vtext text-field) (cursor text-field)))
(setf (cursor text-field) (cursor text-field))))
(when (< 0 (cursor text-field))
(decf (cursor text-field))))
(when (< (cursor text-field) (length (vtext text-field)))
(incf (cursor text-field))))
(setf (cursor text-field) 0))
(setf (cursor text-field) (length (vtext text-field)))))))
(let ((key (key event))
(cursor (cursor text-field)))
(with-accessors ((text-position text-position)) cursor
(case key
(when (<= 1 text-position (length (text text-field)))
(setf (text text-field) (string-remove-pos (text text-field) (1- text-position)))
(decf text-position)))
(when (< -1 text-position (length (text text-field)))
(setf (text text-field) (string-remove-pos (text text-field) text-position))))
(decf text-position))
(incf text-position))
(setf text-position 0))
(setf text-position (length (text text-field))))))))
(defmethod handle ((event text-entered) (text-field text-field))
(setf (vtext text-field) (string-insert-pos (vtext text-field) (cursor text-field) (text event)))
(incf (cursor text-field) (length (text event))))
(setf (text text-field) (string-insert-pos (text text-field) (text-position (cursor text-field)) (text event)))
(incf (text-position (cursor text-field)) (length (text event))))
@@ -6,7 +6,7 @@ Author: Nicolas Hafner <>
(in-package #:org.shirakumo.fraf.trial.ui)
(define-shader-entity ui-window (highlightable-widget rectangular-pane group)
(define-shader-entity ui-window (highlightable-widget pane group)
(defmethod paint :after ((window ui-window) target)
@@ -50,3 +50,9 @@
(when (parent widget)
(note-extent-change (parent widget) widget)))
(defmethod paint :around ((widget widget) target)
(let ((prev (gl:get-integer :scissor-box 4)))
(with-vec4 (x y w h) (extent widget)
(gl:scissor x y w h))
(gl:scissor (aref prev 0) (aref prev 1) (aref prev 2) (aref prev 3))))
@@ -11,9 +11,9 @@
:layout (make-instance 'trial-ui::horizontal-layout :alignment :top)))
(context (make-instance 'trial-ui::ui-context)))
(enter (make-instance 'trial-ui::spacer :preferred-size (vec 0.1 0.1)) window)
(enter (make-instance 'trial-ui::text-field :text "1") window)
(enter (make-instance 'trial-ui::text-field :text "1" :size 48) window)
(enter (make-instance 'trial-ui::spacer :preferred-size (vec 0.1 0.1)) window)
(enter (make-instance 'trial-ui::text-field :text "2") window)
(enter (make-instance 'trial-ui::label :text "2") window)
(enter (make-instance 'trial-ui::spacer :preferred-size (vec 0.1 0.1)) window)
(enter window scene)
(enter window context)

0 comments on commit 683d44d

Please sign in to comment.