cells-gtk-cvs

cells-gtk-cvs@common-lisp.net

371 discussions

[cells-gtk-cvs] CVS root/cells-gtk
by pdenno 19 Feb '06

19 Feb '06

Update of /project/cells-gtk/cvsroot/root/cells-gtk In directory common-lisp:/tmp/cvs-serv14819/root/cells-gtk Modified Files: widgets.lisp Log Message: uffi --> cffi --- /project/cells-gtk/cvsroot/root/cells-gtk/widgets.lisp 2006/02/16 18:18:56 1.17 +++ /project/cells-gtk/cvsroot/root/cells-gtk/widgets.lisp 2006/02/19 20:14:26 1.18 @@ -52,7 +52,7 @@ (defun gtk-objects-init () (setf *gtk-objects* (make-hash-table :size 100 :rehash-size 100))) -(defun gtk-object-store (gtk-id gtk-object &aux (hash-id (pointer-address gtk-id))) +(defun gtk-object-store (gtk-id gtk-object &aux (hash-id (cffi:pointer-address gtk-id))) (unless *gtk-objects* (gtk-objects-init)) (let ((known (gethash hash-id *gtk-objects*))) @@ -68,10 +68,10 @@ (defun gtk-object-forget (gtk-id gtk-object) (when gtk-id (assert *gtk-objects*) - (remhash (pointer-address gtk-id) *gtk-objects*) + (remhash (cffi:pointer-address gtk-id) *gtk-objects*) (mapc #'(lambda (k) (gtk-object-forget (id k) k)) (kids gtk-object)))) -(defun gtk-object-find (gtk-id &optional must-find-p &aux (hash-id (pointer-address gtk-id))) +(defun gtk-object-find (gtk-id &optional must-find-p &aux (hash-id (cffi:pointer-address gtk-id))) (when *gtk-objects* (let ((clos-widget (gethash hash-id *gtk-objects*))) (when (and must-find-p (not clos-widget)) @@ -115,7 +115,7 @@ (defmacro def-gtk-event-handler (event) `(cffi:defcallback ,(intern (format nil "~a-HANDLER" event)) :int ((widget :pointer) (event :pointer) (data :pointer)) - (bif (self (gtk-object-find widget)) + (if-bind (self (gtk-object-find widget)) (let ((cb (callback-recover self ,(intern (string event) :keyword)))) (funcall cb self widget event data)) (trc nil "Unknown widget from prior run. Clean up on errors" widget))))

1 0

[cells-gtk-cvs] CVS root/cells-gtk
by pdenno 19 Feb '06

19 Feb '06

Update of /project/cells-gtk/cvsroot/root/cells-gtk In directory common-lisp:/tmp/cvs-serv14780/root/cells-gtk Modified Files: tree-view.lisp Log Message: use pod-utils --- /project/cells-gtk/cvsroot/root/cells-gtk/tree-view.lisp 2006/02/16 18:18:02 1.14 +++ /project/cells-gtk/cvsroot/root/cells-gtk/tree-view.lisp 2006/02/19 20:13:51 1.15 @@ -113,7 +113,7 @@ (cffi:defcallback tree-view-select-handler :void ((column-widget :pointer) (event :pointer) (data :pointer)) - (bif (tree-view (gtk-object-find column-widget)) + (if-bind (tree-view (gtk-object-find column-widget)) (let ((cb (callback-recover tree-view :on-select))) (funcall cb tree-view column-widget event data)) (trc "Clean up old widgets after runs" column-widget)) @@ -211,7 +211,7 @@ (cffi:defcallback tree-view-render-cell-callback :int ((tree-column :pointer) (cell-renderer :pointer) (tree-model :pointer) (iter :pointer) (data :pointer)) - (bif (self (gtk-object-find tree-column)) + (if-bind (self (gtk-object-find tree-column)) (let ((cb (callback-recover self :render-cell))) (assert cb nil "no :render-cell callback for ~a" self) (funcall cb tree-column cell-renderer tree-model iter data))

1 0

[cells-gtk-cvs] CVS root/cells-gtk
by pdenno 19 Feb '06

19 Feb '06

Update of /project/cells-gtk/cvsroot/root/cells-gtk In directory common-lisp:/tmp/cvs-serv14761/root/cells-gtk Modified Files: textview.lisp Log Message: use pod-utils --- /project/cells-gtk/cvsroot/root/cells-gtk/textview.lisp 2006/02/16 18:17:22 1.8 +++ /project/cells-gtk/cvsroot/root/cells-gtk/textview.lisp 2006/02/19 20:13:26 1.9 @@ -72,8 +72,8 @@ (cffi:defcallback text-view-populate-popup-handler :void ((widget :pointer) (signal :pointer) (data :pointer)) (let ((popup-menu (gtk-adds-text-view-popup-menu widget))) - (bwhen (text-view (gtk-object-find widget)) - (bwhen (cb (callback-recover text-view :populate-popup)) + (when-bind (text-view (gtk-object-find widget)) + (when-bind (cb (callback-recover text-view :populate-popup)) (funcall cb popup-menu)))) 1) @@ -93,7 +93,7 @@ item))) #'(lambda (popup-menu) (loop for old in (old-popups text-view) do - (bwhen (sub (submenu old)) + (when-bind (sub (submenu old)) (gtk-object-forget (id sub) sub)) (gtk-object-forget (id old) old)) (let ((tops (mapcar #'do-padds p-adds)))

1 0

[cells-gtk-cvs] CVS root/cells-gtk
by pdenno 19 Feb '06

19 Feb '06

Update of /project/cells-gtk/cvsroot/root/cells-gtk In directory common-lisp:/tmp/cvs-serv14740/root/cells-gtk Modified Files: packages.lisp Log Message: package does not use :ukt or :uffi --- /project/cells-gtk/cvsroot/root/cells-gtk/packages.lisp 2006/02/16 18:16:55 1.4 +++ /project/cells-gtk/cvsroot/root/cells-gtk/packages.lisp 2006/02/19 20:12:58 1.5 @@ -18,7 +18,7 @@ (defpackage :cells-gtk (:nicknames :cgtk) - (:use :common-lisp :utils-kt :pod :cells :gtk-ffi :uffi )) + (:use :common-lisp :pod :cells :gtk-ffi))

1 0

[cells-gtk-cvs] CVS root/cells-gtk
by pdenno 19 Feb '06

19 Feb '06

Update of /project/cells-gtk/cvsroot/root/cells-gtk In directory common-lisp:/tmp/cvs-serv14720/root/cells-gtk Modified Files: menus.lisp Log Message: use pod-utils --- /project/cells-gtk/cvsroot/root/cells-gtk/menus.lisp 2006/02/16 18:16:28 1.12 +++ /project/cells-gtk/cvsroot/root/cells-gtk/menus.lisp 2006/02/19 20:12:16 1.13 @@ -78,12 +78,12 @@ '(:string :string) pfunc (children-fn self))) ;; Spec says iter must correspond to a path of depth one. But then there would be no point ;; in set-active-iter. Well, the spec seems to be wrong (or poorly worded). - (bwhen (path (init self)) + (when-bind (path (init self)) (cgtk-set-active-item-by-path self path))))) (defmethod cgtk-set-active-item-by-path ((self combo-box) path) "Sets the value of the tree-model type combo-box to the item at the path. Path is a list of integers." - (bwhen (tree (tree-model self)) + (when-bind (tree (tree-model self)) (with-tree-iters (it) (when (gtk-tree-model-get-iter-from-string (id tree) it (format nil "~{~A~^:~}" path)) (gtk-combo-box-set-active-iter (id self) it) @@ -97,7 +97,7 @@ (when new-value (dolist (item (items self)) (gtk-combo-box-append-text (id self) (funcall (print-fn self) item))) - (bif (index (position (init self) (items self))) + (if-bind (index (position (init self) (items self))) (progn (gtk-combo-box-set-active (id self) index) (setf (md-value self) (init self))) (progn (gtk-combo-box-set-active (id self) 0)

1 0

[cells-gtk-cvs] CVS root/cells-gtk
by pdenno 19 Feb '06

19 Feb '06

Update of /project/cells-gtk/cvsroot/root/cells-gtk In directory common-lisp:/tmp/cvs-serv14701/root/cells-gtk Modified Files: layout.lisp Log Message: uffi --> cffi --- /project/cells-gtk/cvsroot/root/cells-gtk/layout.lisp 2006/02/16 18:15:47 1.7 +++ /project/cells-gtk/cvsroot/root/cells-gtk/layout.lisp 2006/02/19 20:11:45 1.8 @@ -217,10 +217,10 @@ (:bottom 3) (t 2))))) -(defun notebook-contains-page-p (notebook widget &aux (wid (pointer-address (id widget)))) +(defun notebook-contains-page-p (notebook widget &aux (wid (cffi:pointer-address (id widget)))) (loop for i from 1 to (gtk-notebook-get-n-pages (id notebook)) for page = (gtk-notebook-get-nth-page (id notebook) (1- i)) - when (= wid (pointer-address page)) return t)) + when (= wid (cffi:pointer-address page)) return t)) (def-c-output show-page ((self notebook)) (when (and new-value (>= new-value 0) (< new-value (length (kids self))))

1 0

[cells-gtk-cvs] CVS root/cells-gtk
by pdenno 19 Feb '06

19 Feb '06

Update of /project/cells-gtk/cvsroot/root/cells-gtk In directory common-lisp:/tmp/cvs-serv14676/root/cells-gtk Modified Files: drawing.lisp Log Message: Use pod-utils --- /project/cells-gtk/cvsroot/root/cells-gtk/drawing.lisp 2006/02/16 18:13:57 1.5 +++ /project/cells-gtk/cvsroot/root/cells-gtk/drawing.lisp 2006/02/19 20:11:03 1.6 @@ -19,7 +19,7 @@ (cffi:defcallback drawing-expose-event-handler :int ((drawing-area :pointer) (signal :pointer) (data :pointer)) (declare (ignorable data signal gkd-event-expose widget)) - (bwhen (self (gtk-object-find drawing-area)) + (when-bind (self (gtk-object-find drawing-area)) (init-graphics-context drawing-area) (gdk-draw-drawable *window* @@ -31,7 +31,7 @@ (cffi:defcallback drawing-button-events-handler :int ((drawing-area :pointer) (signal :pointer) (data :pointer)) (declare (ignorable data)) - (bwhen (self (gtk-object-find drawing-area)) + (when-bind (self (gtk-object-find drawing-area)) (let ((event (gdk-event-button-type signal))) (when (and (eql (event-type event) :button_press) (= (gdk-event-button-button signal) 1)) @@ -47,8 +47,8 @@ (cffi:defcallback drawing-pointer-motion-handler :int ((drawing-area :pointer) (signal :pointer) (data :pointer)) (declare (ignorable data signal widget)) - (bwhen (self (gtk-object-find drawing-area)) - (bwhen (button1 (button1-down self)) + (when-bind (self (gtk-object-find drawing-area)) + (when-bind (button1 (button1-down self)) (let ((dx (- (truncate (gdk-event-motion-x signal)) (car button1))) (dy(- (truncate (gdk-event-motion-y signal)) (cdr button1)))) (loop for drawable being the hash-value of (gobjects self) do

1 0

[cells-gtk-cvs] CVS root/cells-gtk
by pdenno 19 Feb '06

19 Feb '06

Update of /project/cells-gtk/cvsroot/root/cells-gtk In directory common-lisp:/tmp/cvs-serv14657/root/cells-gtk Modified Files: cells-gtk.asd Log Message: :depends-on :pod-utils --- /project/cells-gtk/cvsroot/root/cells-gtk/cells-gtk.asd 2006/02/16 18:11:08 1.7 +++ /project/cells-gtk/cvsroot/root/cells-gtk/cells-gtk.asd 2006/02/19 20:10:27 1.8 @@ -2,7 +2,7 @@ (asdf:defsystem :cells-gtk :name "cells-gtk" - :depends-on (:cells :gtk-ffi) + :depends-on (:cells :pod-utils :gtk-ffi) :serial t :components ((:file "packages")

1 0

[cells-gtk-cvs] CVS root/cells-gtk
by pdenno 19 Feb '06

19 Feb '06

Update of /project/cells-gtk/cvsroot/root/cells-gtk In directory common-lisp:/tmp/cvs-serv14562/root/cells-gtk Modified Files: addon.lisp Log Message: Use uffi package prefix --- /project/cells-gtk/cvsroot/root/cells-gtk/addon.lisp 2004/12/06 20:04:12 1.3 +++ /project/cells-gtk/cvsroot/root/cells-gtk/addon.lisp 2006/02/19 20:09:57 1.4 @@ -27,10 +27,10 @@ (setf (md-value self) (get-date self)))) (defmethod get-date ((self calendar)) - (with-foreign-objects ((year :int)(month :int)(day :int)) + (uffi:with-foreign-objects ((year :int)(month :int)(day :int)) (gtk-calendar-get-date (id self) year month day) - (encode-universal-time 0 0 0 (deref-pointer day :int) - (1+ (deref-pointer month :int)) (deref-pointer year :int)))) + (encode-universal-time 0 0 0 (uffi:deref-pointer day :int) + (1+ (uffi:deref-pointer month :int)) (uffi:deref-pointer year :int)))) (def-c-output init ((self calendar)) (when new-value

1 0

[cells-gtk-cvs] CVS root/pod-utils
by pdenno 19 Feb '06

19 Feb '06

Update of /project/cells-gtk/cvsroot/root/pod-utils In directory common-lisp:/tmp/cvs-serv14536/root/pod-utils Added Files: pod-utils.asd utils.lisp Log Message: New files --- /project/cells-gtk/cvsroot/root/pod-utils/pod-utils.asd 2006/02/19 20:09:12 NONE +++ /project/cells-gtk/cvsroot/root/pod-utils/pod-utils.asd 2006/02/19 20:09:12 1.1 (asdf:defsystem :pod-utils :name "pod-utils" :components ((:file "utils"))) --- /project/cells-gtk/cvsroot/root/pod-utils/utils.lisp 2006/02/19 20:09:12 NONE +++ /project/cells-gtk/cvsroot/root/pod-utils/utils.lisp 2006/02/19 20:09:12 1.1 ;;; Copyright (c) 2004 Peter Denno ;;; ;;; Permission is hereby granted, free of charge, to any person ;;; obtaining a copy of this software and associated documentation ;;; files (the "Software"), to deal in the Software without restriction, ;;; including without limitation the rights to use, copy, modify, ;;; merge, publish, distribute, sublicense, and/or sell copies of the ;;; Software, and to permit persons to whom the Software is furnished ;;; to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be ;;; included in all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. ;;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ;;; ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF ;;; CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION ;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. ;;;----------------------------------------------------------------------- ;;; ;;; Peter Denno ;;; Date: 12/2/95 - on going. ;;; ;;; Generally applicable utilities. Some from Norvig's "Paradigms of ;;; Artificial Programming," Some from Kiczales et. al. "The Art of the ;;; Metaobject Protocol," some from Graham's "On Lisp," some from Sam Steingold. ;;; (in-package :cl-user) (defpackage pod-utils (:nicknames pod) (:use cl) (:export combinations flatten kintern sintern mapappend pairs memo debug-memo memoize clear-memoize defun-memoize VARS mac mac2 load-ht when-bind if-bind when-bind* substring remove-extra-spaces break-line-at read-string-to-list split name2initials c-name2lisp lisp-name2c single-p mklist longer group prune find2 before duplicate split-if mvb mvs dbind decode-time-interval strcat now tree-search depth-first-search prepend breadth-first-search update with-stack-size pprint-without-strings chop setx new-reslist reslist-pop reslist-push reslist-fillptr reuse-cons intersect-predicates defmemo system-clear-memoized-fns system-add-memoized-fn system-list-memoized-fns system-forget-memoized-fns with-gensyms last1 fail trc)) (in-package :pod-utils) ;;; Purpose: Return the combinations possible when selecting one item ;;; from each of the argument sets. ;;; Example: (combinations '(a) '(b c) '(d e)) ;;; => ((A B D) (A B E) (A C D) (A C E)) ;;; Arg: sets - lists ;;; Value: a list of lists. If the argument is nil, it returns nil. (defun combinations (&rest sets) (cond ((null sets) nil) (t (flet ((combinations-aux (aset bset) (cond ((not aset) bset) ((not bset) aset) (t (loop for a in aset append (loop for b in bset collect (list a b))))))) (loop for set in (reduce #'combinations-aux sets) collect (flatten set)))))) (defun flatten (input &optional accumulator) "Return a flat list of the atoms in the input. Ex: (flatten '((a (b (c) d))) => (a b c d))" (cond ((null input) accumulator) ((atom input) (cons input accumulator)) (t (flatten (first input) (flatten (rest input) accumulator))))) (declaim (inline kintern)) (defun kintern (string &rest args) "Apply FORMAT to STRING and ARGS, upcase the resulting string and intern it into the KEYWORD package." (intern (string-upcase (apply #'format nil (string string) args)) (find-package "KEYWORD"))) (declaim (inline sintern)) (defun sintern (string &rest args) "Apply FORMAT to STRING and ARGS, upcase the resulting string and intern it into the current (*PACKAGE*) package." (intern (string-upcase (apply #'format nil (string string) args)))) (defun mapappend (fun &rest args) (loop until (some #'null args) append (apply fun (loop for largs on args collect (pop (first largs)))))) (defun mapnconc (fun &rest args) (loop until (some #'null args) nconc (apply fun (loop for largs on args collect (pop (first largs)))))) ;;; Purpose: Return a list of pairs of elements from the argument list: ;;; Ex: (pairs '(a b c d)) => ((a b) (a c) (a d) (b c) (b d) (c d)) ;;; ;;; Args: inlist - a list (defun pairs (inlist) (loop for sublist on inlist while (cdr sublist) append (loop for elem in (cdr sublist) collect `(,(first sublist) ,elem)))) ;;; Purpose: Called by memoize, below. This returns ;;; the memoized function. Norvig, Page 270. ;;; When you want to use this on &rest args use :test #'equal :key #'identity ;;; Args: fn - the function object. ;;; name - the function symbol. ;;; key - On what argument the result is indexed. ;;; test - Either eql or equal, the :test of the hash table. (defun memo (fn name key test) "Return a memo-function of fn." (let ((table (make-hash-table :test test))) (setf (get name 'memo) table) #'(lambda (&rest args) (let ((k (funcall key args))) (multiple-value-bind (val found-p) (gethash k table) (if found-p val (setf (gethash k table) (apply fn args)))))))) (defun debug-memo (fn name key test) "Like memo but prints *hit* on every hit." (let ((table (make-hash-table :test test))) (setf (get name 'memo) table) #'(lambda (&rest args) (let ((k (funcall key args))) (multiple-value-bind (val found-p) (gethash k table) (if found-p (progn (princ " *HIT*") val) (progn (princ " *miss*") (setf (gethash k table) (apply fn args))))))))) ;;; Purpose: memoize the argument function. ;;; Arguments as those in memo. (defun memoize (fn-name &key (key #'first) (test #'eql) (debug nil)) "Replace fn-name's global definition with a memoized version." #-Allegro-V4.3 (format t "~%;;; Memoizing (~a) ~a ****" test fn-name) #+Allegro-V4.3 (format t "~%;;; Memoizing ~a ****" fn-name) (if debug (setf (symbol-function fn-name) (debug-memo (symbol-function fn-name) fn-name key test)) (setf (symbol-function fn-name) (memo (symbol-function fn-name) fn-name key test)))) ;;; Clear the hash table from the function. (defun clear-memoize (fn-name) "Clear the hash table from a memo function." (let ((table (get fn-name 'memo))) (when table (clrhash table)))) ;;; Purpose: define a function and memoize it. ;;; Limitations: only useful for default arguments, i.e., ;;; key on first and test eql. In all other ;;; cases call (memoize <fn> :key <key> :test <test>). (defmacro defun-memoize (fn args &body body) `(memoize (defun ,fn ,args ,body))) ;;; Stuff to use when you have a serious number of memoized functions, ;;; and you have a notion of "starting over." (defmacro defmemo (fname &body body) `(progn (defun ,fname ,@body) (eval-when (:load-toplevel) (memoize ',fname) (system-add-memoized-fn ',fname)))) (let ((+memoized-fns+ nil)) (defun system-clear-memoized-fns () (mapcar #'(lambda (x) (warn "Clearing memoized ~A" x) (clear-memoize x)) +memoized-fns+)) (defun system-add-memoized-fn (fname) (pushnew fname +memoized-fns+)) (defun system-list-memoized-fns () +memoized-fns+) (defun system-forget-memoized-fns () (setf +memoized-fns+ nil)) ) ;;; Purpose: Diagnostic (From Howard Stearns) that does ;;; (vars a b c) => (FORMAT *TRACE-OUTPUT* "~&a = ~S b = ~S c = ~S ~%" A B C) (defmacro VARS (&rest variables) `(format *trace-output* ,(loop with result = "~&" for var in variables do (setf result (if (and (consp var) (eq (first var) 'quote)) (concatenate 'string result " ~S ") (concatenate 'string result (string-downcase var) " = ~S "))) finally (return (concatenate 'string result "~%"))) ,@variables)) ;;; The most essential macro building tool. (defmacro mac (macro) `(pprint (macroexpand-1 ',macro))) ;;; Similar, but used on 'subtype' macros. (defmacro mac2 (macro) `(pprint (macroexpand-1 (macroexpand-1 ',macro)))) ;;; Dirk H.P. Gerrits' "Lisp Code Walker" slides, ALU Meeting, Amsterdam, 2003. ;;; With additional corrections (beyond that in his notes). (defvar *mea-hooks* (make-hash-table :test #'eq)) (defun macroexpand-all (form &optional env) "Macroexpand FORM recursively until none of its subforms can be further expanded." (multiple-value-bind (expansion macrop) (macroexpand-1 form env) (declare (ignore macrop)) (let* ((key (and (consp form) (car form))) (hook (gethash key *mea-hooks*))) (cond (hook (funcall hook form env)) ((and (consp form) (symbolp (car form)) (macro-function (car form))) (macroexpand-all expansion env)) ((consp form) (cons (car form) (mapcar #'(lambda (arg) (macroexpand-all arg env)) (cdr form)))) (t expansion))))) (defun load-ht (ht key-value-pairs) "Load the argument hash table with the argument values provided in a flat list of <key> <value>. " (loop while key-value-pairs do (setf (gethash (pop key-value-pairs) ht) (pop key-value-pairs))) ht) (defmacro when-bind ((var expr) &body body) "Paul Graham ON LISP pg 145. when+let" `(let ((,var ,expr)) (when ,var ,@body))) (defmacro if-bind ((var expr) then else) `(let ((,var ,expr)) (if ,var ,then ,else))) (defmacro when-bind* (binds &body body) "Paul Graham ON LISP pg 145. when+let*" (if (null binds) `(progn @body) `(let (,(car binds)) (if ,(caar binds) (when-bind* ,(car binds) ,@body))))) (defmacro with-gensyms (syms &body body) "Paul Graham ON LISP pg 145. Used in macros to avoid variable capture." `(let ,(mapcar #'(lambda (s) `(,s (gensym))) syms) ,@body)) (declaim (inline substring)) (defun substring (str1 str2) "Returns the place in str1 where str2 begins or nil if str2 is not in str1" (search str2 str1 :test #'string=)) (defun remove-extra-spaces (string) "Leave only one space between non-space characters of argument string." (let* ((len (length string)) (new-string (make-array len :element-type 'character :fill-pointer 0))) (vector-push (char string 0) new-string) (loop for i from 1 to (1- len) unless (and (char= #\Space (char string i)) (char= #\Space (char string (1- i)))) do (vector-push (char string i) new-string)) new-string)) (defun break-line-at (string break-bag position) "Return the argument STRING with linefeeds inserted at some position past POSITION where a character in the break-bag is encountered." (let* ((len (length string)) (new-string (make-array (* 2 len) :element-type 'character :fill-pointer 0))) (loop for ix from 0 to (1- (length string)) with count = 0 do (vector-push (char string ix) new-string) (incf count) when (and (> count position) (find (char string ix) break-bag)) do (vector-push #\Linefeed new-string) (setf count 0) finally (return new-string)))) (defun read-string-to-list (string) (loop with val = nil and start = 0 do (multiple-value-setq (val start) (read-from-string string nil :eof :start start)) until (eql val :eof) collect val)) ;;; (cl-ppcre:split "\\s+" "foo bar baz frob") ;;; ("foo" "bar" "baz" "frob") ;;; http://weitz.de/cl-ppcre/#split (defun split (string c &key min-size) "Like the perl split, split the string using the character. Return a list of substrings." (let ((result (loop for i from 0 to (1- (length string)) with start = 0 with size = 0 do (incf size) when (and (char= c (char string i)) (or (not min-size) (> size min-size))) collect (subseq string start i) into result and do (setf start (1+ i) size 0) finally (return (append result (list (subseq string start))))))) (if (zerop (length (first (last result)))) (butlast result) result))) (defun name2initials (string) "For 'abc' return 'a'. For 'product_definition_formation' return 'pdf', etc." (let ((result (make-array 31 :element-type 'character :fill-pointer 0)) (len (length string))) (vector-push (char string 0) result) (loop for i from 1 to (1- len) when (and (char= (char string i) #\_) (< i (1- len))) do (vector-push (char string (+ i 1)) result) (incf i)) result)) (defun c-name2lisp (c-string) "aNameLikeThis --> a-name-like-this" (let* ((len (length c-string)) (result (make-array (* 2 len) :element-type 'character :fill-pointer 0))) (vector-push (char c-string 0) result) (loop for i from 1 to (1- len) for char = (char c-string i) do (when (upper-case-p char) (vector-push #\- result)) (vector-push char result)) (string-downcase result))) (defun lisp-name2c (in-string &aux (lisp-string (string-downcase in-string))) "a-name-like-this --> aNameLikeThis" (let* ((len (length lisp-string)) (result (make-array len :element-type 'character :fill-pointer 0))) (vector-push (char lisp-string 0) result) (loop for i from 1 to (1- len) for char = (char lisp-string i) with upper-next = nil do (cond ((char= char #\-) (setf upper-next t)) (t (vector-push (if upper-next (char-upcase char) char) result) (setf upper-next nil)))) result)) ;;;============================================= ;;; A bunch more from Paul Grahams's "On Lisp." ;;;============================================= (declaim (inline single-p last1 mklist)) (defun single-p (lst) "List contains just one thing." (and (consp lst) (not (cdr lst)))) (defun last1 (lst) (car (last lst))) (defun mklist (obj) "Make the argument a list if it isn't already." (if (listp obj) obj (list obj))) (defun longer (x y) "Return true if x longer than y -- only for lists." (labels ((compare (x y) (and (consp x) (or (null y) (compare (cdr x) (cdr y)))))) (if (and (listp x) (listp y)) (compare x y) (> (length x) (length y))))) (defun group (source n) (if (zerop n) (error "zero length")) (labels ((rec (source acc) (let ((rest (nthcdr n source))) (if (consp rest) (rec rest (cons (subseq source 0 n) acc)) (nreverse (cons source acc)))))) (if source (rec source nil) nil))) [374 lines skipped]

1 0

← Newer
1
...
9
10
11
12
13
14
15
...
38
Older →

Jump to page:

2025

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

cells-gtk-cvs