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))