[Morphologie-cvs] r12 - in trunk: . src
ksprotte at common-lisp.net
ksprotte at common-lisp.net
Thu Jul 5 15:43:39 UTC 2007
Author: ksprotte
Date: Thu Jul 5 11:43:38 2007
New Revision: 12
Modified:
trunk/morphologie.asd
trunk/src/missing-om-functions.txt
trunk/src/morphologie.lisp
trunk/src/tests.lisp
Log:
structure-1 works!! (choose-new-file-dialog too...)
Modified: trunk/morphologie.asd
==============================================================================
--- trunk/morphologie.asd (original)
+++ trunk/morphologie.asd Thu Jul 5 11:43:38 2007
@@ -3,6 +3,9 @@
(defsystem :morphologie
:components
((:module :src
+ :serial t
:components
- ((:file "morphologie"))))
+ ((:file "package")
+ (:file "utils")
+ (:file "morphologie"))))
:depends-on (:ompw))
Modified: trunk/src/missing-om-functions.txt
==============================================================================
--- trunk/src/missing-om-functions.txt (original)
+++ trunk/src/missing-om-functions.txt Thu Jul 5 11:43:38 2007
@@ -1,4 +1,3 @@
-om::group-list
om::dx->x
om::arithm-ser
om::x-append
@@ -17,6 +16,3 @@
om::flat
om::x->dx
om::om+
-om::flat-once
-
-
Modified: trunk/src/morphologie.lisp
==============================================================================
--- trunk/src/morphologie.lisp (original)
+++ trunk/src/morphologie.lisp Thu Jul 5 11:43:38 2007
@@ -10,41 +10,41 @@
;;;* *
;;;*************************************************************************************************************
-(defpackage :morph2 (:use :cl :ompw))
+(in-package :morph)
-(in-package :morph2)
-
-;;; watch out for functions like OM::group-list
+;;; watch out for functions like OM::....
;;; still in this file
-;;; first some om utils
-(defun list! (thing)
- (if (listp thing) thing (list thing)))
-
-(defun mat-trans (matrix)
- (assert (apply #'= (mapcar #'length matrix)) nil
- "this should not happen. Please report this to Kilian Sprotte")
- (when matrix (apply #'mapcar #'list matrix)))
-;;; end utils
-
-(define-ompw list-part (list &optional ncol)
- "partitions LIST in NCOL lists containing the elements modulo NCOL"
- :non-generic t
- (let ((vector (make-array ncol)) res)
- (loop :while list
- :do (loop :for i :from 0 :to (1- ncol)
- :do (and list
- (setf (svref vector i)
- (push (pop list) (svref vector i))))))
- (loop :for i :from 0 :to (1- ncol)
- :do (push (remove nil (nreverse (svref vector i))) res))
- (nreverse res)))
+;; I tried to get this version of LIST-MODULO to run - but there is a problem
+;; with this code.
+;; see my reimplementation below
+
+;; (define-ompw list-modulo (list &optional ncol)
+;; "partitions LIST in NCOL lists containing the elements modulo NCOL"
+;; :non-generic t
+;; (let ((vector (make-array ncol)) res)
+;; (loop :while list
+;; :do (loop :for i :from 0 :to (1- ncol)
+;; :do (and list
+;; (setf (svref vector i)
+;; (push (pop list) (svref vector i))))))
+;; (loop :for i :from 0 :to (1- ncol)
+;; :do (push (remove nil (nreverse (svref vector i))) res))
+;; (nreverse res)))
(define-ompw list-modulo (list &optional ncol)
+ "partitions LIST in NCOL lists containing the elements modulo NCOL"
:non-generic t
- (list-part list ncol))
-
+ ;; new implementation by Kilian
+ ;; should produce the same result
+ ;; I assume that NCOL would not be a very
+ ;; large number - so efficiency should be fine
+ (let ((result-lists (make-list ncol)))
+ (loop for i = 0 then (mod (1+ i) ncol)
+ for elt in list
+ do (push elt (nth i result-lists)))
+ (map-into result-lists #'nreverse result-lists)))
(defun less-deep-mapcar (fun list? &rest args)
"Applies FUN to LIST? ARGS if LIST? is a one-level list .
@@ -649,7 +649,7 @@
(setf b1 nil)
(setf b1 (append (list (car l)) (n-n-1l l)))
(setf b2 (append b1 (list (- (length list) (car (last l))))))
- (push (remove 'nil (OM::group-list list b2 1)) res))
+ (push (remove 'nil (group-list list b2 1)) res))
(list (car c) (reverse res))))
(defun segnum1 (seq)
@@ -658,7 +658,7 @@
(res1 nil)
(res2 nil))
(dotimes (n (length seq1)) (push (list (nth n seq1) (+ n 1)) res1))
- (setf res1 (OM::flat-once (reverse res1)))
+ (setf res1 (flat-once (reverse res1)))
(dotimes (n (length seq))
(setf res2 (member (nth n seq) res1 :test 'equal))
(push (list res2 (second res2)) seq2))
@@ -668,7 +668,7 @@
(let ((seqs (second list)) (a nil) (b nil) (c nil) (res nil))
(dolist (s seqs)
(setf c (segnum1 s))
- (setf a (remove-duplicates (OM::flat-once (car c))))
+ (setf a (remove-duplicates (flat-once (car c))))
(setf b (cdr c))
(setf a (mat-trans (reverse (list-modulo a 2))))
(push (list a (car b)) res))
@@ -676,7 +676,7 @@
(defun form (segs)
(let ((res nil))
- (setf segs (OM::flat-once (cdr segs)))
+ (setf segs (flat-once (cdr segs)))
(dolist (s segs (reverse res)) (push (cadr s) res))))
(defun take-date ()
@@ -724,7 +724,7 @@
(format stream "~S " (nth n (cadr from-struct-1)))
(format stream "~%~%"))))
-(define-ompw structure-1 ((seq nil) &optional (alpha? :alpha) (smooth? :yes)
+(define-ompw structure-1 ((seq (a b c a b c d a c c d a a b c a)) &optional (alpha? :alpha) (smooth? :yes)
(result :extend) (levels 1) (smth2? :no))
"Donne toutes les structures possibles d'une séquence de nombres ou de symboles
selon une segmentation contrastive, et ce de manière récursive.
@@ -788,7 +788,7 @@
(with-open-file (out-st out-file :direction :output :if-exists
:supersede :if-does-not-exist :create)
(view-str-1 seq res seg alpha? out-st date run-time))
- (set-mac-file-creator out-file 'ttxt)
+ ;; (set-mac-file-creator out-file 'ttxt)
(format t "DONE~%"))
((eql :short result)
(if (eql :alpha alpha?)
@@ -1633,7 +1633,8 @@
:create)
(to-stream seq list-patterns seuil formes
completion-patterns out-st date run-time))
- (set-mac-file-creator out-file 'ttxt))
+ ;; (set-mac-file-creator out-file 'ttxt)
+ )
((= result 5)
(to-stream-1-jbs list-patterns formes
completion-patterns)))))))))
@@ -3848,7 +3849,7 @@
(defun tronc (extrem noeuds)
(dolist (e extrem
- (remove-duplicates (OM::flat-once noeuds) :test 'equalp))
+ (remove-duplicates (flat-once noeuds) :test 'equalp))
(dotimes (n (length noeuds))
(setf (nth n noeuds)
(remove-if #'(lambda (x) (equalp e x)) (nth n noeuds))))))
Modified: trunk/src/tests.lisp
==============================================================================
--- trunk/src/tests.lisp (original)
+++ trunk/src/tests.lisp Thu Jul 5 11:43:38 2007
@@ -1,8 +1,13 @@
-(in-package :morph2)
+(in-package :morph)
(ptrn-find '(1 2 3 1 2 3 1 2 1 2) nil)
(ptrn-reson '(a b c a b c b b b b a a) 5)
(ptrn-smooth '(a b c d b b))
-(structure-1 '(a b c a b c d a c c d a a b c a))
+(assert (equal (list-part '((a b c a b c) 1 (d a c) 2 (d a b c a) 3) 2)
+ '(((a b c a b c) (d a c) (d a b c a)) (1 2 3))))
+
+(assert (equal (list-part '(a b c a b c 1 d a c 2 d a b c a 3) 4)
+ '((a b a a 3) (b c c b) (c 1 2 c) (a d d a))))
+(structure-1 '(a b c a b c d a c c d a a b c a))
More information about the Morphologie-cvs
mailing list