Changeset main,28 for main/cdk.lisp

Timestamp:

11/04/2007 06:19:33 AM (19 years ago)

Author:

David Owen <dsowen@…>

branch-nick:

tui-new

revision id:

dsowen@fugue88.ws-20071104061933-b5oiof728551luy5

Message:

Major overhaul to get rid of CDK stuff, and modularize all the ncurses stuff.
Using CLOS for genericity.

File:

• main/cdk.lisp (modified) (5 diffs)

main/cdk.lisp

@@ -1 +1 @@
 (defpackage #:cdk
-  (:use #:cl #:cffi)
-  (:export #:with-screen #:with-der-window #:add-string #:add-clipped-string
-           #:wmove))
+  (:use #:cl #:cffi #:dso-util)
+  (:export #:+err+ #:+ok+))
 
 (in-package #:cdk)
@@ -17 +16 @@
 ;;; Global constants.
 
-(defctype chtype :uint64)
-(defctype wchar :int32)                 ; On my 64-bit laptop.
+
+
+(defconstant +err+ -1)
+(defconstant +ok+ 0)
 
 (defcvar ("cdk_exit_early" +cdk-exit-early+) :int :read-only t)
@@ -27 +28 @@
 ;;; Screen-wide, initialization, and finalization routines.
 
-(defcfun ("initscr" c-init-curses-screen) :pointer)
 
 (defcfun ("start_color" c-curs-start-color) :int)
 
-(defcfun ("endwin" c-end-curses) :int)
-
-(defmacro with-screen ((screen) &body body)
-  `(let ((,screen (c-init-curses-screen)))
-     (unwind-protect (progn ,@body)
-       (c-end-curses))))
-
-(defcfun ("initCDKScreen" c-init-cdk-screen) :pointer
-  (curseswindow :pointer))
-
-(defcfun ("initCDKColor" c-init-color) :void)
-
-(defcfun ("eraseCDKScreen" c-erase-screen) :void
-  (screen :pointer))
-
-(defcfun ("destroyCDKScreen" c-destroy-screen) :void
-  (screen :pointer))
-
-(defcfun ("endCDK" c-end-cdk) :void)
-
-(defcfun ("refreshCDKScreen" c-refresh-screen) :void
-  (screen :pointer))
-
-(defcfun ("newwin" c-new-window) :pointer
-  (lines :int)
-  (columns :int)
-  (y :int)
-  (x :int))
-
-(defcfun ("subwin" c-sub-window) :pointer
-  (orig :pointer)
-  (lines :int)
-  (columns :int)
-  (y :int)
-  (x :int))
-
-(defcfun ("derwin" c-der-window) :pointer
-  (orig :pointer)
-  (lines :int)
-  (columns :int)
-  (y :int)
-  (x :int))
-
-(defcfun ("delwin" c-delete-window) :int
-  (window :pointer))
-
-(defmacro with-der-window ((window parent lines columns y x) &body body)
-  `(let ((,window (c-der-window ,parent ,lines ,columns ,y ,x)))
-     (when (null-pointer-p ,window)
-       ;; TODO: Replace this with a condition and a restart.
-       (error "Couldn't create window."))
-     (unwind-protect (progn ,@body)
-       (c-delete-window ,window))))
-
-(defcfun ("box" c-box) :int
-  (window :pointer)
-  (vertical-ch chtype)
-  (horizontal-ch chtype))
-
-(defcfun ("wborder" c-window-border) :int
-  (window :pointer)
-  (ls chtype)
-  (rs chtype)
-  (ts chtype)
-  (bs chtype)
-  (tl chtype)
-  (tr chtype)
-  (bl chtype)
-  (br chtype))
-
-(defcfun ("wbkgd" c-set-window-background) :int
-  (window :pointer)
-  (ch chtype))
-
-(defcfun "wbkgrnd" :int
-  (window :pointer)
-  (wch :pointer))
-
-(defcfun ("werase" c-erase-window) :int
-  (window :pointer))
-
-(defcfun "getcury" :int
-  (window :pointer))
-
-(defcfun "getcurx" :int
-  (window :pointer))
-
-(defcfun "getmaxy" :int
-  (window :pointer))
-
-(defcfun "getmaxx" :int
-  (window :pointer))
-
-(defcfun "wmove" :int
-  (window :pointer)
-  (y :int)
-  (x :int))
-
-(defcfun "wadd_wch" :int
-  (window :pointer)
-  (wch :pointer))
-
-(defcstruct cchar_t
-  (attr chtype)
-  (char :uint32 :count 5))
 
 
 
-(defcvar ("_nc_wacs" nc-wacs) :pointer :read-only t)
 
-(defun wacs-char (ch)
-  (let ((code (char-code (ecase ch
-                           (:ul-corner #\l)
-                           (:ll-corner #\m)
-                           (:ur-corner #\k)
-                           (:lr-corner #\j)
-                           (:r-tee #\u)
-                           (:l-tee #\t)
-                           (:b-tee #\v)
-                           (:t-tee #\w)
-                           (:h-line #\q)
-                           (:v-line #\x)
-                           (:plus #\n)
-                           (:solid #\0)))))
-    (inc-pointer nc-wacs (* (foreign-type-size 'cchar_t) code))))
-
-(defcfun "wadd_wchnstr" :int
-  (window :pointer)
-  (cchstr :pointer)
-  (n :int))
-
-(defun clear-complex-char (cc)
-  (with-foreign-slots ((attr char) cc cchar_t)
-    (setf attr 0)
-    (dotimes (i 5 cc)
-      (setf (mem-aref char :uint32 i) 0))))
-
-(defun extract-complex-char (cc)
-  (let ((x (make-sequence '(vector integer) 5 :initial-element 0)))
-    (with-foreign-slots ((char) cc cchar_t)
-      (dotimes (i 5 x)
-        (setf (aref x i) (mem-aref char :uint32 i))))))
-
-(defun copy-complex-char (dst src-vector)
-  (with-foreign-slots ((char) dst cchar_t)
-    (dotimes (i 5 dst)
-      (setf (mem-aref char :uint32 i) (aref src-vector i)))))
-
-(defun set-complex-char (cc ch)
-  (with-foreign-slots ((char) cc cchar_t)
-    (etypecase ch
-      (character
-       (setf (mem-aref char :uint32) (char-code ch)))
-      (symbol
-       (copy-complex-char cc (extract-complex-char (wacs-char ch)))))))
-
-(defun add-complex-string (window s)
-  (let ((n (length s)))
-    (with-foreign-object (a 'cchar_t n)
-      (dotimes (i n)
-        (let ((cc (mem-aref a 'cchar_t i)))
-          (clear-complex-char cc)
-          (set-complex-char cc (aref s i))))
-      (wadd-wchnstr window a n))))
-
-(defcfun ("wmove" c-wmove) :int
-  (window :pointer)
-  (y :int)
-  (x :int))
-
-(defcfun "waddnwstr" :int
-  (window :pointer)
-  (wstr :pointer)
-  (n :int))
-
-(defun add-string (window s)
-  (let ((n (length s)))
-    (with-foreign-object (a 'wchar n)
-      (dotimes (i n)
-        (setf (mem-aref a 'wchar i) (char-code (aref s i))))
-      (waddnwstr window a n))))
-
-(defun move-and-add-string (window y x s)
-  (wmove window y x)
-  (add-string window s))
-
-(defun add-clipped-string (window y x s)
-  (let ((maxy (getmaxy window)))
-    (unless (<= 0 y maxy) (return-from add-clipped-string)))
-  (let ((maxx (getmaxx window)))
-    (when (< x 0)
-      (setf s (subseq s (- x))
-            x 0))
-    (let ((over (- (+ x (length s)) maxx)))
-      (when (> over 0)
-        (setf s (subseq s 0 (- (length s) over)))))
-    (move-and-add-string window y x s)))
-
-(defcfun ("wrefresh" c-refresh-window) :int
-  (window :pointer))
 
 (defun color-pair (n)
@@ -237 +41 @@
 
 
-;;; Generic functions.
 
-(defcfun ("bindCDKObject" c-bind-key) :void
-  (object-type :int)
-  (object :pointer)
-  (key chtype)
-  (function :pointer)
-  (user-data :pointer))
-
-(defcfun ("cleanCDKObjectBindings" c-clear-bindings) :void
-  (object-type :int)
-  (object :pointer))
-
-(defcfun ("setCDKObjectBackgroundColor" c-set-background-color) :void
-  (object :pointer)
-  (color :string))
-
-
-
-;;; Labels.
-
-(defcfun ("newCDKLabel" c-new-label) :pointer
-  (screen :pointer)
-  (x-pos :int)
-  (y-pos :int)
-  (message :pointer)
-  (message-lines :int)
-  (box :boolean)
-  (shadow :boolean))
-
-(defcfun ("freeCDKLabel" c-free-label) :void
-  (label :pointer))
-
-(defcfun ("waitCDKLabel" c-wait-on-label) :char
-  (label :pointer)
-  (key :char))
-
-(defun new-label (screen row column text &optional box shadow)
-  (let* ((cstr (foreign-string-alloc text))
-         (array (foreign-alloc :pointer :initial-element cstr :count 1))
-         (label (c-new-label screen column row array 1 box shadow)))
-    (foreign-free array)
-    (foreign-string-free cstr)
-    label))
-
-
-
-;;; Entries.
-
-(defcfun ("newCDKEntry" c-new-entry) :pointer
-  (screen :pointer)
-  (x-pos :int)
-  (y-pos :int)
-  (title :string)
-  (label :string)
-  (attribute :int)
-  (filler :int)
-  (display-type :int)
-  (width :int)
-  (minimum-length :int)
-  (maximum-length :int)
-  (box :boolean)
-  (shadow :boolean))
-
-(defcfun ("freeCDKEntry" c-free-entry) :void
-  (entry :pointer))
-
-(defcfun ("activateCDKEntry" c-activate-entry) :string
-  (entry :pointer)
-  (actions :string))
-
-(defcfun ("setCDKEntryHighlight" c-set-entry-highlight) :void
-  (entry :pointer)
-  (highlight :unsigned-int)             ; Still not sure about this.
-  (cursor :boolean))
-
-(defcfun ("getCDKEntryExitType" c-entry-exit-type) :int
-  (entry :pointer))
-
-(defcfun ("getCDKEntryValue" c-get-entry-value) :string
-  (entry :pointer))
-
-(defcfun ("setCDKEntryValue" c-set-entry-value) :void
-  (entry :pointer)
-  (new-value :string))
-
-(defcfun ("setCDKEntryExitType" c-set-entry-exit-type) :void
-  (entry :pointer)
-  (ch chtype))
-
-
-
-(defcfun ("wattron" c-wattron) :int
-  (window :pointer)
-  (attrs :int))
-
-(defcfun ("wattroff" c-wattroff) :int
-  (window :pointer)
-  (attrs :int))
 
 (defcfun ("wgetch" c-wgetch) :int
@@ -349 +55 @@
 
 (defcfun ("nonl" c-nonl) :int)
+
+(defcfun ("wattron" c-wattron) :int
+  (window :pointer)
+  (attrs :int))
+
+(defcfun ("wattroff" c-wattroff) :int
+  (window :pointer)
+  (attrs :int))
+