^v T/Řhome:oci;oci.lisp.newestF6,CCLFIND-CLASS-CELL,?COMMON-LISPQUOTE?SOURCE-NOTET[(defpackage oci (:use common-lisp coeden) (:export #:MKLIST #:INTERLEAVE #:GROUP #:GRAPHICALIZE #:GRAPH->LINES #:IMAGE->LINES #:IMAGE->BLOCKS #:BLOCKS->GRAPH #:SHRINK-LST #:INSTANTIATE-RECTANGLE #:MERGE-BLOCKS #:HAF-TRANSFORM #:MOUNT-BLOCKS #:BRESENHAM-LINE #:DITER #:MAKE-GRAPH #:DIJKSTRA-SHORTEST-PATH #:WIDEN-LINES #:RENDER-SVG-PATH #:LINES->SVG-PATH #:TREE->LINES #:REDRAW #:WORSEN-VISIBILITY #:ASSIGNMENT #:MAKE-COST-MATRIX #:GRAPH-COST #:GRAPH43 #:ADD23 #:GRAFS->TREE #:GRAFS->FILE #:GATHER-FRUIT #:ALIST->HASH #:OBSERVE-WORD #:BOXIFY #:CARVE-INTO-BOXES #:COPY-RECT #:write-netpbm #:read-netpbm #:fourier-search #:negate-grayscale-image #:logarithm-filter #:shrink-image #:fourier-mellin-search #:mark-image #:join-centres #:filter-centres #:restore-rect #:image-mean #:hough+sobel-circle-transform #:hough+sobel-line-transform #:grayscale-image #:average #:euclidean-distance #:treshold-fourier! #:pad-image #:img<-path #:remember-img #:prune #:reap-meat #:dilate-points #:cut-into-words #:grayscale->bitmap! #:new-point #:point-i #:point-j #:power-of-2-ceiling #:chamfer-transform! #:image-not #:list-boxes #:hr-distance *this-file* *lng* *omg* *frg* *oak* *acorn* *scripts* ))9L-u^UHjRjRAyh 0h 0h 0h 0h 0Ah 0A 0I 0XI$%QfffŃOCI,ECOEDENECOMMON-LISP,E*SCRIPTS*E*ACORN*E*OAK*E*FRG*E*OMG*E*LNG*E*THIS-FILE*EHR-DISTANCEELIST-BOXESEIMAGE-NOTECHAMFER-TRANSFORM!EPOWER-OF-2-CEILINGEPOINT-JEPOINT-IENEW-POINTEGRAYSCALE->BITMAP!ECUT-INTO-WORDSEDILATE-POINTSEREAP-MEATEPRUNEEREMEMBER-IMGEIMG<-PATHEPAD-IMAGEETRESHOLD-FOURIER!EEUCLIDEAN-DISTANCEEAVERAGEEGRAYSCALE-IMAGEEHOUGH+SOBEL-LINE-TRANSFORMEHOUGH+SOBEL-CIRCLE-TRANSFORMEIMAGE-MEANERESTORE-RECTEFILTER-CENTRESEJOIN-CENTRESEMARK-IMAGEEFOURIER-MELLIN-SEARCHESHRINK-IMAGEELOGARITHM-FILTERENEGATE-GRAYSCALE-IMAGEEFOURIER-SEARCHEREAD-NETPBMEWRITE-NETPBMECOPY-RECTECARVE-INTO-BOXESEBOXIFYEOBSERVE-WORDEALIST->HASHEGATHER-FRUITEGRAFS->FILEEGRAFS->TREEEADD23EGRAPH43EGRAPH-COSTEMAKE-COST-MATRIXEASSIGNMENTEWORSEN-VISIBILITYEREDRAWETREE->LINESELINES->SVG-PATHERENDER-SVG-PATHEWIDEN-LINESEDIJKSTRA-SHORTEST-PATHEMAKE-GRAPHEDITEREBRESENHAM-LINEEMOUNT-BLOCKSEHAF-TRANSFORMEMERGE-BLOCKSEINSTANTIATE-RECTANGLEESHRINK-LSTEBLOCKS->GRAPHEIMAGE->BLOCKSEIMAGE->LINESEGRAPH->LINESEGRAPHICALIZEEGROUPEINTERLEAVEEMKLIST?%DEFINE-PACKAGE,%FUNCTION-SOURCE-NOTEF6(in-package oci)9L-u"UHI9IAc ff?SET-PACKAGE,F6(declaim (inline cref))9@L-u"UHI9IAc ff,INLINEOCICREFPROCLAIM,F6(defun cref (image i j &optional (v 0)) (if (array-in-bounds-p image i j) (aref image i j) v))9@a#L- H~HlHlEUHt rtAPWV s  h 0uɸ 0E@%P} u1HuLEH}HuIS L-l@ tLEH}Hu$%8QHuÐfffARRAY-IN-BOUNDS-P,PC-SOURCE-MAPr+`M]r/LFUNCTION-SYMBOL-MAPVJIIMAGE0?r?f?f?fC,LAMBDA,?&OPTIONAL, ,DECLARE,GLOBAL-FUNCTION-NAME,BLOCK,IF,,?AREFF6(defun graph-node (g i) (car (svref g i)))9*#L-uQUHWVH}HuuGu8@u:HGHHH9s1Ht7u*Hv׶-3gI,Y)I(G0?Y?YGRAPH-NODEF6(defun (setf graph-node) (val g i) (setf (car (svref g i)) val))9@#L-uiUHAPWVH}HuuGuN@uPHGHHH9sGH|7HuugTfff,r%Jb1BT6A0?r?r?r?r,F6(defun make-graph (ld lst) (let ((len (length lst))) (let ((va (apply #'vector lst)) (ga (make-array (list len len)))) (dotimes (i len) (dotimes (j len) (setf (aref ga i j) (funcall ld (svref va i) (svref va j))))) (values ga va))))9=A# L-UHWVAWAVATASHufff%pSL-VHu1MMfff$%xQL-I1fffffS L-VuuȹMfffff$%xPL-lHǰI9ffS L-LVLeuE1Huff%PRL-,HL]E1Lfffff%PRL-HAVAWDuAD$AID$HHI9Kt4VDuAD$AID$HHI9Kt<_H]؃LOLDK AL-L_AXH]؃{vH{kH{]A[@YL;C#WHC+H9RHIH<LC fffff% RL-L@u HHffff%SL-ILLސ%hSL-|@ wL@u H(Hfff%SL-DILHu%hSL-,@ HuATL]LeLuL}$%Pf ܶ#-Iܶcmͳ˃sHH?HH (aref d v) (+ w (aref d u)))) (setf (aref d v) (+ w (aref d u)) (aref p v) u)))) (dijkstra tg e (push (cons u (aref d u)) s) k d p))))))) (let ((d (make-array (array-dimension graph 0) :initial-element most-positive-fixnum)) (p (make-array (array-dimension graph 0) :initial-element nil))) (setf (aref d elt) 0) (values p (dijkstra graph end '() (loop for i below (array-dimension graph 0) collect i) d p)))))9# LL-^H~HlHlEUHE1HMEff$% QL-AWAVATASLu} u1Hu} uNL1IQfffffS L-t@u HH%SL-LHuL1IQS L-,IjRjRhAWh 0h 0HSh.0h 0A 0 0 0PIYfffS L-VL1IQfffS L-IjRjRhAWh 0h 0h 0h.0h 0A 0 0 0PIYffS L-dVLEH}1@ I@HHH9ID8ujRjRAVuh 0L1IQS L-VE1 0 0eH,% eH%eH;%we$%H{HsIMLHp uH9 0Mv%fff%PSL-@ AS 0eH,% eH%eH;%we$%L{HsHI_ff%pPL-$L@u HHffff%SL-I-It$HI 0HIH}Hu0IaL-VL]LeLuL}$%PHH?HH'.?".?iO?-i,?i?diXiF6(declaim (inline new-point))9ۀL-u"UHI9IAc ff,NEW-POINT,F6(defun new-point (i j) (cons i j))9"# L-uIUHWVH}HueH,% eH%eH;%we$%H{HsHÐ,P!0?P?P,,,,,,?CONSF6(declaim (inline point-i))9L-u"UHI9IAc ff,POINT-I,F6(defun point-i (p) (car p))9@#L-uUHVuHv,!0?!Ϲ,,,,,CARF6(declaim (inline point-j))9@L-u"UHI9IAc ff,POINT-J,F6(defun point-j (p) (cdr p))9#L-uUHVuHv,!0?!,,,,,CDRF6(defun square (num) (* num num))9@ #L-uUHVHHu$%(S, ?NUM0? ?SQUAREF6(defun average (&rest args) (let ((len (length args))) (if (zerop len) 0 (/ (apply #'+ args) len))))9k#L-H~HlHlEUHM5fff$%QL-Huffff%pSL-VH@uH 0Dv%1%8SL-@ t1Hu1Mff$%xQL-\IfffffS L-DHHu$%0Sffff+,<jU>iPhScUBMARGS0?U?<AVERAGEF6S(defun euclidean-distance (p1 p2) ;(sqrt (apply #'+ (mapcar #'square (mapcar #'- p1 p2))))) (let ((dy (- (point-i p1) (point-i p2))) (dx (- (point-j p1) (point-j p2)))) (sqrt (+ (* dy dy) (* dx dx)))))9*#SL-AUHWVAWL}D.IwVL}DIw_ uHH)Hfff% SL-VL}D=IwVL}D-Iw_ uHH)Hfffff% SL-,IH}Hufffff%(SL- VLLff%(SL-_ u Hfff%SL-HA_Ic ff4HH?HHl1Lk`jU_BIj9j#80 1d1`1DITER9AF6(defun read-netpbm (fname) (labels ((bread (f) (case (read-char f) (#\0 0) (#\1 1) (t (bread f))))) (with-open-file (f fname) (let ((rt (copy-readtable))) (multiple-value-bind (fun mid) (get-macro-character #\;) (set-macro-character #\# fun mid rt) (let* ((*readtable* rt) (magic (read f)) (width (read f)) (height (read f)) (max (if (string= "P1" (symbol-name magic)) nil (read f))) (rid (if (string= "P1" (symbol-name magic)) #'bread #'read)) (image (make-array `(,height ,width) :element-type '(unsigned-byte 8)))) (dotimes (i height (values image max)) (dotimes (j width) (setf (aref image i j) (funcall rid f))))))))))9{#sbL-UHVAWAVATASI Vh 0h 0MMM$%TfffML-} t2} 0Dv%ILEȹIfffS L-tfffL-dHuI!ffffS L-DHuI1I)ffffS L-$VMAR;I14%/c L-)sHcH) h 0ujRjRh#LEHxHu I9fffS L-HuIAMu$%HPL-LIIfffffS L-dVLIIffffS L-DVLIIffffS L-$VHXIQfS L-IYIaffS L-@ uLIIS L- 0VHXIQffS L-IiIaffS L-|@ tHuIIH^ ؃dHVHPM$%xPL-,IjRjRh8AWh 0h 0h 0h 0h 0A 0 0 0PIqffS L-VHE1H(%PRL-HLPE1Lfff%PRL-HLH8؃LOLDK fffffAL-THH!aHHH0كM{CH{8H{8*A(A&L;s#$HK+I9HII<LC HHADL@u HH%SL-ILLސ%hSL-|@ L@u HHfff%SL-DILH(fff%hSL-$@ g0@fffff%TL-HPM%fff$%xRL-HMEfff$%xRL-M]ff$%RL-.0Hu1M}$%@RL-|HM$%8PL-\eH<%HeH%0HWHHXHH_eH%0yHxeH4%?s L]LeLuL}$%PfͦͶͳHH?HHgptu*\ DG32569DG32567DDIMS?RIDMAXHEIGHTWIDTHMAGIC?MIDFUN?RTDG32565DG32564DBREAD?FNAME0W T.?4+?2%,$?0,?.D,?,,?*,?(,?&|,? *,?*,?, ,?/? *? %?F6R(defun write-netpbm (f image) (with-open-file (fd f :direction :output :if-exists :supersede :if-does-not-exist :create) (let ((magic (if (search "pbm" f) "P1" "P2")) (height (array-dimension image 0)) (width (array-dimension image 1)) (count 1)) (format fd "~a~%~a ~a~%" magic width height) (if (string= magic "P2") (format fd "255")) (dotimes (i height) (dotimes (j width) (if (string= magic "P2") (format fd "~%~a" (aref image i j)) (progn (if (> count 70) (progn (setf count 1) (format fd "~%"))) (format fd "~a" (aref image i j)) (incf count))))) (format fd "~%"))))9"R#L-UHWVAWAVATASh 0h 0MME$%TfffEL-} t2} 0Dv%ILEȹI fffS L-|fffL-ljRjRuAAA!M)I1I98IAS L-$HuIIIHuIQS L-@ t IYIaVH}1IifffS L-VH}HIiffffS L-VjjRjRATAqLEHxHu(IyffS L-dH}IIfffffS L-<@ MA taMD؃uACLkI0u+IsHHHHHHH 0Dv%IH 0Dv%@ t&LIIfffS L->jRjRAI.0tMA 01 0 IfS L-duE1Hhfff%PRL-DHxE1H`%PRL-HH}IIffffS L-@ t?LELLf%8QL-IMIyS L-Hp@uH0 0Ov%H0fffff%HSL-l@ t2HHpLIIyfffS L-4ATLELLffff%8QL-VLXA txAWHHuGHkVH0u2HHHvHHHHHHH 0Dv%H@HH 0Dv%H@ t,MIHPIffS L-d6I.0tL 0HPIffffS L-,HHp@u HHffff%SL-HpL@u HHfffff%SL-ILH`fff%hSL-@ HL@u HH%SL-dILHhfff%hSL-D@ HMARLIIy4%/c ffffL-H Mfff$%xRL-M5ff$%RL-.0Hu1MU$%@RL-HMu$%8PuL-eH<%HeH%0HWHHXHH_eH%0yHxeH4%?s L]LeLuL}$%PfHH?HH (point-j a) (point-j b)))))97~#2L-=UHAWAVATIIMD#IwVMDIw_ uH9 0Lv%%XSL-@ MDIwVMDIw_ uH9 0Dv%ff%8SL-,@ tZMDIwVMDu~Iw_ uH9 0Ov%ff%HSL-A\A^A_þ 0A\A^A_A\A^A_#:, I}~A?|4`{ozcn~D_S^~GR t77M+6 6*0:M#6 I I/-POINT<F"6(defparameter saxons (let ((s #(:hor :dia011 :dia022 :dia033 :dia045 :dia056 :dia067 :dia078 :ver :dia101 :dia112 :dia123 :dia135 :dia146 :dia157 :dia168))) (setf (get :curve-q1 :angle) 45) (setf (get :curve-q2 :angle) 135) (setf (get :curve-q3 :angle) 45) (setf (get :curve-q4 :angle) 135) (setf (get :dot :angle) 0) (dotimes (a (length s) s) (setf (get (svref s a) :angle) (* a 11.25)))))9WDL-UHAWAVATMM!I)HhLfffS L-M1I)H8LS L-M9I)HhLS L-dMAI)H8LS L-tmp (a) (svref saxons (floor a 11.25)))95F #L-UHVIHK*1eH; %@CeH%HH4BHDsteVH}IIfS L-_uGu5@u7HGHHH9s.Ht7ff͓m׶g.A4FLOOR,4Il$30? ANGLE->TMPF6(defun angle~ (diff sym1 sym2) (let ((a1 (if (symbolp sym1) (get sym1 :angle) sym1)) (a2 (if (symbolp sym2) (get sym2 :angle) sym2))) (if (> diff (abs (- a1 a2))) t (cond ((= 0 a1) (> diff (abs (- 180 a2)))) ((= 0 a2) (> diff (abs (- a1 180))))))))9#L-UHVAWAVATASMIMMA tD 0Dv%.0@ t$LII fS L-LVL}A tD 0Dv%.0@ t&H}II S L-O*R/=A2DG32613A1DG32611?SYM2?SYM1?DIFF0~? z-R?* * *#?ANGLE~F6(defun %rotate-point (c s p) (new-point (round (+ (* (point-i p) c) (* (point-j p) s))) (round (- (* (point-j p) c) (* (point-i p) s)))))9'#TL-UHAPWAWAVIMDIwHHuff%(SL-VMDbIwHHufff%(SL-_ u H6fff%SL-\IfS L-DVMDVIwHHufff%(SL-VMD.IwHHufff%(SL-_ uHH)Hfffff% SL-IfS L-VH}HueH,% eH%eH;%we$%H{HsHHA^A_f!PHH?HHblacks (image) (let (blacks (bl 0) (height (array-dimension image 0)) (width (array-dimension image 1))) (dotimes (i height) (dotimes (j width) (if (not (zerop (aref image i j))) (progn (incf bl) (push (new-point i j) blacks))))) (values (nreverse blacks) bl height width)))9g;#zL-UHAWAVATASIh 0jL1IffS L-VLHIfffffS L-VuE1Hufffff%PRL-tHLeE1Lfffff%PRL-LHQMLL%8QL-,H@uH 0Ev%1%@SL-@ Hu@u HHff%SL-HuAVAWH}HueH,% eH%eH;%we$%H{HsHHHHueH,% eH%eH;%we$%H{HsHHuL@u H;Hfffff%SL-ILL%hSL-@ L@u HDHfff%SL-ILHu%hSL-@ 7HHuعIS L-Vuuu L]LeLuL}$%PffHH?HHBLACKSF6Z(defun move-and-clip-rectangle (lim y x height width rect) (let (new (mil 0)) (dolist (p rect) (let ((nx (+ x (point-j p))) (ny (+ y (point-i p)))) (if (and (>= ny 0) (< ny height) (>= nx 0) (< nx width)) (push (new-point ny nx) new) (if (= (incf mil) lim) (return-from move-and-clip-rectangle nil))))) (nreverse new)))9Z#!L-0Hl$ Hl$ EAPWVAWAVATASA 0jutHuLfMDIwH} u Hz%SL-tVMDIwH} u Hff%SL-4ILuL@uH 0Mv%1f%PSL-@ !LHu uH9 0Lv%f%XSL-@ L@uH 0Mv%1fffff%PSL-@ LHu؉ uH9 0Lv%f%XSL-\@ t}AWAVH}HueH,% eH%eH;%we$%H{HsHHHeH,% eH%eH;%we$%H{L[IvHu@u HzHf%SL-HuHHu uH9 0Dv%%8SL-|@ t 0HA[A\A^A_HHuHvHu} HLHA[A\A^A_Ic ff=RHH?HHv>OuOez?NX?NYDG32630?MIL?NEWRECTXYLIM0??Re O?4?1 /? )?)?)?)?)?)6MOVE-AND-CLIP-RECTANGLEF6E(defun instantiate-rectangle (rect) (let ((i-max (point-i (car rect))) (i-min (point-i (car rect))) (j-max (point-j (car rect))) (j-min (point-j (car rect)))) (dolist (p (cdr rect)) (setf i-max (max i-max (point-i p))) (setf j-max (max j-max (point-j p))) (setf i-min (min i-min (point-i p))) (setf j-min (min j-min (point-j p)))) (let ((a (make-array (list (1+ (- i-max i-min)) (1+ (- j-max j-min))) :initial-element 0))) (dolist (p rect) (setf (aref a (- (point-i p) i-min) (- (point-j p) j-min)) 1)) (values a i-min j-min))))9 E# L-)UHVAWAVATASHuLfDIt$VHuLfDIt$VHuLfDIt$VHuLfDIt$VL]HuvHuLfLuMD~IwILL uH9 0Ov%fffff%HSL-@ tLLHuLuMD%IwILL uH9 0Ov%ffff%HSL-T@ tLLHuMMDIwILL uH9 0Lv%fffff%XSL-@ tLLILuMDvIwILL uH9 0Lv%fffff%XSL-@ tLLHuHuHvHu} SHH}Lމ uHH)Hfff% SL-4@u H-H%SL- VH}Hu uHH)HPfffff% SL-@u HH%SL-VMmfff$%xPL-IjRjRhATh 0h 0jh.0h 0A 0 0 0PI!ffffS L-A<@:M;G#8IG+H93HIH<MG ID8HuHvHu} HAWASuL]LeLuL}$%P!3L^we$HH?HH&=^^^ZHrPdDG32647DDIMSDG32646DG32645DG32644DG32643DG32642DG32641DG32640DG32639DG32636?I-MIN?J-MIN?J-MAX?I-MAX700F ?4 w:z$:!z{e{bZZ ~? 4?4 ?4 ^r? H4 3G?4=INSTANTIATE-RECTANGLEF663(eval-when (:execute :load-toplevel :compile-toplevel) (defun condlet-binds (vars cl) "Paul Graham. On Lisp, p.146" (mapcar #'(lambda (bindform) (if (consp bindform) (cons (cdr (assoc (car bindform) vars)) (cdr bindform)))) (cdr cl))))939#DL-UHWVAWAVATAS 0 0eH,%X eH%XfD)8fD)xeo<%H8HheH%HH@HxHpHIAWHH3eH)%eH%eH;%wHCe$%HH-$FFLHFF %hQFMH}LVH~#HH~+HIHuL^D؃McLL؃LOLDK AL-H 0eH,% eH%eH;%we$%H{HsHLff%pPL-\HL~M[A [HuHveH%HHeH%HeH%XHA[A\A^A_2fffL-UHWAWIDDIHuIffffS L-ukHvVDucIw_eH,% eH%eH;%we$%H{HsHA_þ 0A_Ð)\kfff?ASSEQL,U)kz)j)\)<)Yi?BINDFORMVARS0?"6@9؁,CONDLET-BINDS,DG32671DG32673DG32672DG32670DG32669CLA0 ' ? sq???BEPaul Graham. On Lisp, p.146F6"60(eval-when (:execute :load-toplevel :compile-toplevel) (defun condlet-clause (vars cl bodfn) "Paul Graham. On Lisp, p.146" `(,(car cl) (let ,(mapcar #'cdr vars) (let ,(condlet-binds vars cl) (,bodfn ,@(mapcar #'cdr vars)))))))9 ;9 Ix#L-UHAPWVAWAVATASHuvA 0 0eH,%X eH%XfD)8fD)xeo<%H8HheH%HH@HxHpHIAWIH^ ؃IL]D؃McLL؃LOLDK fffffAL-H 0eH,% eH%eH;%we$%H{HsHLff%pPL-HL~M[A UHuHvHeH%HHeH%HeH%XVAH}HuIffS L-LV 0 0eH,%X eH%XfD)8fD)xeo<%H8HheH%HH@HxHpHIAWIH^ ؃IL]D؃McLL؃LOLDK ffffAL-H 0eH,% eH%eH;%we$%H{HsHLff%pPL- adx ady) (pdx sdx) (pdy 0) (ddx sdx) (ddy sdy) (ef ady) (es adx)) (t (pdx 0) (pdy sdy) (ddx sdx) (ddy sdy) (ef adx) (es ady))) (let ((x xstart) (y ystart) (error (/ es 2))) (push (new-point y x) line) (dotimes (i es) (decf error ef) (if (minusp error) (progn (incf error es) (incf x ddx) (incf y ddy)) (progn (incf x pdx) (incf y pdy))) (push (new-point y x) line))))) (nreverse line)))9 ~#s!L- Hl$Hl$EAPWVAWAVATASH}Hu uHH)Hff% SL-VH}Hu uHH)Hfffff% SL-lVh 0HueH,%X eo<%HeH%XfD)8fD)x8HheH%HH@VHpHxH}HuIS L-VHuIfffS L-VHuIfffS L-VHuIfffS L-IL}LuLeLL uH9 0Ov%ffff%HSL-\@ tXATATASAVAWjRjRHuVHuVHuVujuLxHpHhHIffL-H(VASATASAWAVjRjRHuVHuVHuVjuuLxHpHhHIffL-H(HMARHuHvI4%/c ffffL-leH%HHeH%HeH%XL]LeLuL}$%PHH?HHfff%SL-\ILHuЉ u Hifff%SL-,ILHuȉ u Hfff%SL-I^LHu u Hf%SL-ILHu؉ u Hfff%SL-IAVAWHxHpeH,% eH%eH;%we$%H{HsHHVHuHv_eH,% eH%eH;%we$%H{HsHLE1% RL-L@u HHffff%SL-ILHu%hSL-@  0HA[A\A^A_HH?HH I bU%T$qm -Gm-GfrNZ#<eE8WX`?Y3?X3Y2X2Y1X1Y0X0?E3?E2?E1?E0*0L980Jq?,mJ1G?*-J?(J?&Jq?$mJ1G?"-J? J?JO??J?eJE?J?J?J?mJ?8J?8J?8J 8J 4J[`F"6(defparameter *lim1* 0.80)9 '*LIM1*.?LF"6(defparameter *lim2* 0.99)9 '?*LIM2*.?}pF"6(defparameter *lim3* 1/24)9 @'*LIM3*6  F"6(defparameter *ugol* 11.25)9'*UGOL*.A4F6(defun limit (w l a) (declare (ignore a)) (1+ (floor (* w l *lim3*))))9J#'L-UHAPWVI1HK*1eH; %@CeH%HH4BHDs~H}ff%(SL-H}ffff%(SL-I9fS L-l@uHp1Hfff%SL-Dff͓HH?HH='< & ?%CXd0DG328587TYPE0??npF6i(defun rectal-testi (blacks blocks covered rectangle lb lim bl w l a height width y x) (declare (optimize (speed 3) (safety 0))) (declare (type (unsigned-byte 12) w l height width)) (declare (type (unsigned-byte 24) lb bl)) (declare (type (simple-array bit (* *)) blacks covered)) (labels ((set-n-return (rect blacks covered blocks w l a lb bl la) (dolist (p rect) (setf (aref blacks (point-i p) (point-j p)) 0 (aref covered (point-i p) (point-j p)) 1)) (values (cons (list (if (= w l) :dot (angle->tmp a)) w lb (sort rect #'point<)) blocks) (- bl la)))) (let ((la 0) (rect (move-and-clip-rectangle lim y x height width rectangle))) (declare (type (unsigned-byte 12) la)) (if (null rect) (values blocks bl) (progn (dolist (p rect) (incf la (aref blacks (point-i p) (point-j p)))) (if (> la 0) (if (> lim (- lb la)) (set-n-return rect blacks covered blocks w l a lb bl la) (let ((lc 0)) (declare (type (unsigned-byte 12) lc)) (dolist (p rect) (incf lc (aref covered (point-i p) (point-j p)))) (if (> lim (- lb la lc)) (set-n-return rect blacks covered blocks w l a lb bl la) (values blocks bl)))) (values blocks bl)))))))9D##L-Hl$`Hl$`EAPWVAWAVATASjjRjRuuuLEH}Hu0IffS L-V` u(uuȹLpLxLuL}$%PL`McMDIwVMDIw_LEI@+HHHIp HHHFDkHhL u Hffff%SL-ILhM[A VHhH2H}HhHH)HH}Љ uH9 0Ov%ff%HSL-t@ tTjRjR`uuuuuuLEH}HhLpLxLuL}PI$%QE1`HXLfMDIvVMDIv_LEI@+HHHIp HHHFDkLLމ u H%SL-|IMHXHvHXX KHH}HhHH)HHL)HH}Љ uH9 0Ov%ff%HSL-@ tTjRjR`uuuuuuLEH}HhLpLxLuL}PI$%QuuȹLpLxLuL}$%PuuȹLpLxLuL}$%PffHH?HHLk|L`r{<L\d<R."QDO8C^U^DG32876DG32877DG32873?LCDG32871DG32872DG328687t89g3:_?RECTANGLEvu40 [, ?(~'.. . <?&U?$"? ? ? ? ? ? ? ? ? ? ? ? ? ? sw9F6K(defun copy-image (image) (declare (optimize (speed 3) (safety 0))) (let ((copy (make-array (array-dimensions image) :element-type 'bit))) (declare (type (simple-array bit (* *)) copy)) (dotimes (i (array-dimension image 0) copy) (dotimes (j (array-dimension image 1)) (setf (aref copy i j) (aref image i j))))))9K#Z L-UHAWAVATASILIfffS L-IjRjRhAWh 0h 0h 0h 0h 0A 0 0 0PIffS L-|VL1IfffS L-\VE1Huf%PRL-DH1LHIfffffS L-IE1Lސ%PRL-HMLL%8QL-H]HC+HII<LC HH@tI@I@L@u HHffff%SL-|ILLސ%hSL-d@ gL@u HHfff%SL-,ILHu%hSL-@ HuHA[A\A^A_ÐHH?HH (/ bl lb) *lim1*) (if points (= w l) (and (> lb 3) (>= (/ l 1.0 w) 3.0)))) (loop for a single-float below (if points *ugol* 180.0) by *ugol* do (multiple-value-bind (rr lb) (build-rectangle 0 0 w l a) (let ((lim (limit w l a))) (dolist (p schwarz) (multiple-value-setq (blocks blin) (rectal-testi blacks blocks covered rr lb lim blin w l a height width (point-i p) (point-j p))) (if (zerop blin) (return-from %lcd blocks)))))))))))) (looper nil) (if *points* (looper t)) blocks)))9cI#]L-Hl$0Hl$0EAPWV 0 0eH,%X eH%XfD)8fD)xeo<%H8HheH%HH@HxHpHVMffff%(PL-|h 0HueH,%X eo<%HeH%XfD)8fD)x8HheH%HH@VHpHxH}uHueH,%X eo<%HeH%XfD)8fD)x8HheH%HH@VHpHxH}jRjRHuVHuVHuVHuVHuVHuVHuVHuVHuVLEH} 0`IfffffL-|IHN*1eH; %@CeH%HHBHD^ tUjRjRHuVHuVHuVHuVHuVHuVHuVHuVHuVLEH}.0`IfL-HuHvVHM5ffff$%xRL-eH%HHeH%HeH%XeH%HHeH%HeH%XHM$%xRL-lHM$%8PL-LeH%HHeH%HeH%X$%PSF L-Hl$PHl$PEAPWVAWAVATASuHx@uH 0Nv%1ffff%`SL-@ HuVHx@u HHff%SL-lVLpHhI9PHxL%(SL-blacks image) (sort (%lcd (min height width) (max height width) bl (copy-image image) (make-array (list height width) :element-type 'bit :initial-element 0) schwarz height width) #'> :key #'third)))9v1#HL- UHVAWAVATASMEARHuI94%/c EL- )sHcH) h 0uLeL]jRjRjRjRMMLL uH9 0Lv%%XSL-T@ tLLVMMLL uH9 0Ov%%HSL-@ tLLVuHuIAfffS L-VATASM5$%xPL-IjRjRhAWh 0h 0jh.0h 0A 0 0 0PIIffffS L-tVLELL޹@IQfffffS L-LVIYH^ ؃uWHVIaH^ ؃uFHIiAXL]LeLuL} Iq$%Qffͦͦfff5z>CADDRq,0rn/'."vtzzLTiDDIMSDG32916DG32915DG32914DG3291330?} r n? j? j? HAF-TRANSFORMF6(defun sb-length (sb) (euclidean-distance (car sb) (car (last sb))))9@D#L-uUUHVuNHvVHuIfS L-u+Hv_Ic f<fff^,[C J3B <8A*2SB0?[ SB-LENGTHF6U(defun sb-straight-line-middle (sb) ;(mapcar #'average (car sb) (car (last sb))) (new-point (/ (+ (point-i (car sb)) (point-i (car (last sb)))) 2) (/ (+ (point-j (car sb)) (point-j (car (last sb)))) 2)))9#XL-UHAWAVIDM~DIwVLIS L-_L~DTIw_ u HA%SL-\HH%0SL-DVDiM~D^IwVLIfffffS L-3L~D(Iw_ u H%SL-HH%0SL-VH}HueH,% eH%eH;%we$%H{HsHHA^A_f.\nHH?HH 2 (euclidean-distance x y))) (and (>= 1 (abs (- (point-i x) (point-i y)))) (>= 1 (abs (- (point-j x) (point-j y))))))9 #ML-mUHWVAWL}DZIwVL}DJIw_ uHH)H1fff% SL-IafS L-tH@uH 0Nv%HH%PSL-D@ L}DIwVL}DIw_ uHH)Hffff% SL-IafS L-H@uH 0Nv%HH%PSL-A_þ 0A_4HH?HH pos 0.66) :e)))) )))9`#cL-UHAWAVATASIIDIwVIH^ ؃HLAXIfffffS L-VLI!ffffS L-lOHvVIH^ ؃9HLAXIffffS L-V} t3H]Ѐ t*A)A1L]LeLuL}$%P} tI1HA[A\A^A_À} tI)HA[A\A^A_LI9fffffS L-VD}Iw_IAfffS L-\VLIIffffS L-<_%0SL-,ILIQfff%XSL- @ tI1HA[A\A^A_MQASML_ uH9 0Nv%%`SL-@ tLIYf%`SL- 0@ tIaHA[A\A^A_LIYffff%HSL-\@ tI)HA[A\A^A_þ 0HA[A\A^A_ff"=ͦͦufff?MEMBER-TEST^ES.>.?(M,"T8sqYkEQ-TuTtsu[ju`i6R?K"5.6DG32940POSEP?SP0 q ? ?u""SB-POSITIONF6G(defun same-line-p (v a b r) (let ((s (car (sort-rect v (list (car a) (car b))))) (e (cadr (sort-rect v (list (car (last a)) (car (last b))))))) (let ((q1 (- (point-j s) (point-j e))) (q2 (- (point-i e) (point-i s))) (q3 (- (* (point-i s) (point-j e)) (* (point-i e) (point-j s)))) (q4 (euclidean-distance s e)) (points (append a b))) (let ((vals (mapcar #'(lambda (p) (abs (/ (+ q3 (* q1 (point-i p)) (* q2 (point-j p))) q4))) points))) (let ((rat (/ (count-if #'(lambda (v) (>= r v)) vals) (length points)))) (> rat 0.9))))))9G#|q!L- Hl$Hl$EAPWVAWAVATASHuvHuvMmfffff$%xPL-H}IffffS L-lOvHuIfffS L-<'vHuIfffS L- vMfff$%xPL-H}IffffS L-HvvL}DIwVL}DIw_ uHH)Hvfff% SL-'2Q3Q1Q2Q40? ? $>?!?!?!?!?!"69&M,SAME-LINE-P L-uAUHWVH}Hu uH9 0Mv%fff%PSL-ff,F00?F?F"69D,#C?COUNT-IF.?fff,)FgEiDC7B!0 le %}$e| %d =T%<g~D^$kqv~)-Q)t:P>SHO)>@G?RAT?VALSDG32946DG32948DG32947DG32945DG32944"! 00$  ?jh???i|AT)<?%?k~?g??)?)?)?)#F6(defun intersecsion (a b) (intersection a b :test #'adjacent-p))9V@#L-uIUHWVjRjRuIiH^ ؃u/HIqLE Iy$%Qf ͦ]?INTERSECTION,O?12>0?O?O%INTERSECSIONF6M(defun cross-relation (a b) (let ((fa (fourth a)) (fb (fourth b))) (let ((i (intersecsion fa fb))) (if (and i (not (eq (car a) (car b))) ; забыл, почему нот эк :( (>= (length i) (min (second a) (second b)))) (let ((si (sort i #'point<))) (list (sb-position fa si) (sb-position fb si)))))))9AM#fL-UHAWAVATASIIDxIvnHvdHvZvDPIt$EHv;Hv1vH}HuйI)ffS L-,IA DIvVDIt$_H9wL%pSL-VDIvvDIt$L~H}L uH9 0Lv%%XSL-d@ tHuLH_ uH9 0Mv%fffff%PSL-$@ I1H^ ؃HL߹I9S L-IH}LIAS L-VH}LIAfS L-VMufff$%xPL-HA[A\A^A_þ 0HA[A\A^A_"5GYj~%8I]ͦfff&,"LIKoJIH=\4G< 3 s%$ SIDG32964DG32963?FB?FA0o?I ? ?j ""'CROSS-RELATIONF6R(defun block-extension-p (a b) (when (intersecsion (fourth a) (fourth b)) (if (eq :dot (car b)) t (unless (eq :dot (car a)) (same-line-p (car a) (fourth a) (fourth b) (min (cadr a) (cadr b)))))))9#lL-UHAWAVIIDlIwbHvXHvNHvVDBIv8Hv.Hv$Hv_IYfffS L-4@ DIvI;au .0A^A_DIwI;aYjRjRDAwDIwHvHvHvVDIvzHvpHvfHvVDZIwPvDFIv<vH}Hu uH9 0Lv%fffff%XSL-@ tHuHuH_AXLuL} Ii$%Q 0A^A_þ 0A^A_Ð1CUh{!4GYk~fff&#,!PivX~4}!4qzTe]d'Kh@Jg5?DG32969DG329680?X?X*BLOCK-EXTENSION-PF6k(defun block-joint (a b) (let ((i (sort (intersecsion (fourth a) (fourth b)) #'point<))) (when i (values (multiple-value-list (sb-position (fourth a) i)) (multiple-value-list (sb-position (fourth b) i)) i))))9#_L-MUHWVAWHu;Hv1Hv'HvHvVHuHvHvHvHv_IfffS L-4VIH^ ؃H_IfffS L-IA >MARHuHvwHvmHvcH~LI 4%/c fL-tMff$%xPL-\VMARHu HvHvHvH~LI 4%/c ffffL-M5ff$%xPL-VAWL}$%P 0A_Ð.@Ri{ͦ0BT&,XX_Om<$}fOW*NeCMd8B0X?X?X,BLOCK-JOINTF"6c(defparameter *curves* '((165 :s 20 :s) (20 :e 45 :s) (45 :e 90 :s) (90 :e 120 :s) (120 :e 135 :s) (135 :e 0 :e) (165 :e 120 :s) (120 :e 90 :s) (90 :e 45 :s) (45 :e 0 :s) (70 :e 45 :s) (45 :e 0 :s) (0 :s 135 :s) (135 :e 90 :s) (90 :e 135 :s) (135 :e 20 :e) (0 :e 20 :s) (20 :e 70 :s)))9CAc'?*CURVES*,,  ,  -, - Z, Z x, x ,  ,  x, x Z, Z -, - , F -, - ,  ,  Z, Z ,  ,  ,  FF"6@(defparameter *not-curves* '((0 :e 90 :s) (0 :s 90 :s) (112 :s 67 :s) (112 :s 90 :s) (90 :s 67 :s) (90 :e 112 :e) (67 :e 112 :e) (0 :e 135 :s) (135 :e 0 :s)))9'?*NOT-CURVES*,,  Z,  Z, p C, p Z, Z C, Z p, C p,  ,  F6u(defun curve? (a1 p1 a2 p2) (when (> a1 a2) (rotatef a1 a2) (rotatef p1 p2)) (cond ((and (eq p1 :e) (eq p2 :s)) ; (format t "1 ~a ~a ~a ~a ~a~%" a1 p1 a2 p2 (< 90 (- 180 (- a2 a1)))) (< 90 (- 180 (- a2 a1)))) ; тупой угол ((and (eq p1 :s) (eq p2 :e)) ; (format t "2 ~a ~a ~a ~a ~a~%" a1 p1 a2 p2 (< 90 (- 180 (- a2 a1)))) (< 90 (- 180 (- a2 a1)))) ; тупой угол ((and (eq p1 :s) (eq p2 :s)) ; (format t "3 ~a ~a ~a ~a ~a~%" a1 p1 a2 p2 (< 90 (- a2 a1))) (< 90 (- a2 a1))) ; тупой угол ((and (eq p1 :e) (eq p2 :e)) ; (format t "4 ~a ~a ~a ~a ~a~%" a1 p1 a2 p2 (< 90 (- a2 a1))) (< 90 (- a2 a1))) ; тупой угол ; (t (format t "0 ~a ~a ~a ~a ~a~%" a1 p1 a2 p2 'nol)) ))9#3.L- !Hl$Hl$EAWAVATASIIML}LL uH9 0Ov%fffff%HSL-@ t(AWAVL}LuHHATASLeL]HHM;iM;qLL uHH)Hkf% SL-$HǠ@uHH)Hfff% SL-H@uH 0Ov%HHfff%XSL-A[A\A^A_M;qM;iLL uHH)Hgffff% SL-dHǠ@uHH)Hfff% SL-4H@uH 0Ov%HHfff%XSL-A[A\A^A_M;quM;quvLL uHH)Hgffff% SL-H@uH 0Ov%HHfff%XSL-tA[A\A^A_M;iuM;iuvLL uHH)H;ffff% SL-$H@uH 0Ov%HHfff%XSL-A[A\A^A_þ 0A[A\A^A_HH?HHMj~.=2j$-DG32985DG32984DG32983DG32982&'0? ? ? nz? l~ 2-2- 2-2-.CURVE?F6_(defun block-same-p (a b) (multiple-value-bind (p1 p2 i) (block-joint a b) (let ((a1 (get (car a) :angle)) (a2 (get (car b) :angle))) (cond ((null i) nil) ((eq :dot (car b)) t) ((eq :dot (car a)) nil) (t (some #'identity (mapcar #'(lambda (p) (curve? a1 (car p) a2 (cadr p))) (interleave #'list nil p1 p2))))))))9_#L-UHWVAWAVATASMMARH}HuI4%/c fffML-)sHcH) h 0uHuIH~II!fffffS L-TVHuH~II!fffS L-V} u 0H(A[A\A^A_HuHvI;)u.0H(A[A\A^A_HuHvI;)u 0H(A[A\A^A_I1H^ ؃rHV 0 0eH,%X eH%XfD)8fD)xeo<%H8HheH%HH@HxHpHIAWHHCeH)%eH%eH;%wHCe$%HH-$FFLHFF %hQFM9H}LELVH~#LF+HH~3HIjRjRIAH^ ؃vHVA 0H}Hu IIfffS L-TID؃:MsLL؃LO!LDK AL- H 0eH,% eH%eH;%we$%H{HsHLff%pPL-HL~M[A [HuHvHeH%HHeH%HeH%XILujRjRjA 0LLL]LeLuL} IQ$%Qfv4iͦmͦ- %IDENTITYL-uaUHAPWVjRjRuHuuLHvVHuuAHvu;HvH}AX I$%Qf2@/,g-.N$,- '&0?g?g?g"609@.,BLOCK-SAME-PPLISTINTERLEAVESOME-XX-ONE,^rQ]\bZfGNb~bb0O0Fzr`gT;LDG32993DG32994DG32991DG32995DG32992DG32990DG32989&'0K a b????r?r? r??02F6(defun group (pred lst &key (key #'identity) every sorter rem not-every) "groups list elements according to pred[icate]: (1 1 2 1) -> ((1 1 1) (2)); if EVERY is true, ensures that PRED is true for any pair within a group; if EVERY is funcallable, calls it with group so far and a potential member, then ANDs the result with that of predicate, which is called for every pair within a group, unless NOT-EVERY is true; REM filters potential group members." (labels ((grpr (pred test key lst group rest) (if (null lst) (nreverse group) ;(values (nreverse group) (nreverse rest)) (if (null group) (grpr pred test key (cdr lst) (list (car lst)) rest) (if (cond ((or (functionp test) (fboundp test)) (and (some #'(lambda (e) (funcall pred (funcall key e) (funcall key (car lst)))) group) (funcall test group (car lst)))) (test (every #'(lambda (e) (funcall pred (funcall key e) (funcall key (car lst)))) group)) (t (some #'(lambda (e) (funcall pred (funcall key e) (funcall key (car lst)))) group))) (if (and test (not not-every)) (grpr pred test key (cdr lst) (cons (car lst) group) rest) (grpr pred test key (append (cdr lst) rest) (cons (car lst) group) nil)) (grpr pred test key (cdr lst) group (cons (car lst) rest)))))) (groupr (pred lst key every rem groups) (let ((ls (if rem (funcall rem (car lst) (cdr lst)) (cdr lst)))) (let ((group (grpr pred every key ls (list (car lst)) nil))) (let ((rest (set-difference lst group))) (if (null rest) (nreverse (if (null group) groups (cons group groups))) (groupr pred (if sorter (sort rest sorter) (nreverse rest)) ; nreverse?? key every rem (if (null group) groups (cons group groups))))))))) (groupr pred lst key every rem nil)))9#L-H~HlHlEUHE1HMEf$% QL-} uIH^ ؃uJHHujRjRHuVHuVuuuLEH} 0@I$%QYͦfffqEVERYSORTER?REM?NOT-EVERY1UL-@YHl$0Hl$0EAPAWAVATASIIL}A tWD+IwVDIw_L۹؃LOLDK fffAL-tDIwVjRjRHuVuuuDI 0eH,% eH%eH;%we$%H{HsH߾ 0LE8IffffL-ILLIS L-V} u[A uL4eH,% eH%eH;%we$%LsLcHHA[A\A^A_Ic jRjRHuVHuVu} t!H}HuIS L-$HuIfffS L-VuA uL4eH,% eH%eH;%we$%LsLcHLLEL]LeLuL}ȹ@L$%Q7Kgfffe[L-8aHl$(Hl$(EVAWAVATASIML]LuA uLA[A\A^A_Ic A jRjRHuVASAVuDIwVDI 0eH,% eH%eH;%we$%H{HsHHuAXL]LeLuL}й8L$%QDt'LIfffS L-@ SeH,%X`eH %HeH%XHnfD)yHH9u8HheH%H@ HpH-$FFLHFF %hQFMLLEMLVH~#LF+LN3HH~;HVATjRjRjA 0H}Hu IffS L- HeH%HHeH%HeH%X@ DZIwLL؃LOALDK fffAL-@ lA eH,%X`eH %HeH%XHnfD)yHH9u8HheH%H@ HpH-$FFLHFF %hQFMLLEMLVH~#LF+LN3HH~;HVATjRjRjA.0H}Hu IffffS L-HeH%HHeH%HeH%X@ ZeH,%X`eH %HeH%XHnfD)yHH9u8HheH%H@ HpH-$FFLHFF %hQFMLLEMLVH~#LF+LN3HH~;HVATjRjRjA 0H}Hu IffffS L-HeH%HHeH%HeH%X@ RA } jRjRHuVASAVuDIwVDIeH,% eH%eH;%we$%H{LcHHuAXL]LeLuL}й8L$%QjRjRHuVASAVuD^IHuعIffS L-VD5IeH,% eH%eH;%we$%H{LcH߾ 0AXL]LeLuL}й8L$%QjRjRHuVASAVuDIwVDIHueH,% eH%eH;%we$%H{HsHLAXL]LeLuL}й8L$%Qo ><mfff2?FBOUNDPL- Hl$Hl$EAPWVH]؃LO}LDK AL-VHuufHvH]؃LO|SLDK fffffAL-t_H]ɉ؃LO|,LDK A*Qhfff,!XM@WM_MV!L0?PREDKEY0?!?!?!?!"669Y?GRPRGROUP5L- Hl$Hl$EAPWVH]؃LO}LDK AL-VHuufHvH]؃LO|SLDK fffffAL-t_H]ɉ؃LO|,LDK A*Qhfff,!VM>UM_KT!L.=9:0?!?!?!?!"669W;=L- Hl$Hl$EAPWVH]؃LO}LDK AL-VHuufHvH]؃LO|SLDK fffffAL-t_H]ɉ؃LO|,LDK A*Qhfff,!VM>UM_KT!L.=9:0?!?!?!?!"669W;=,4m6Ummm}Iu,"tmYom_h<l6M<O>G,@/&y y 3& & & _oU_:UEU4::DDG33011DG33010DG33009DG33008DG33007DG33006REST<:TEST9NOT-EVERY0?,?*?$?"? ? ?4m 4m4m?4m4m 0m?,m669U;9SET-DIFFERENCE2,1eeD'eEee ?u ?yM=L*<KKVKQEKiyox3<7)K^(7J> ((1 1 1) (2)); if EVERY is true, ensures that PRED is true for any pair within a group; if EVERY is funcallable, calls it with group so far and a potential member, then ANDs the result with that of predicate, which is called for every pair within a group, unless NOT-EVERY is true; REM filters potential group members.F6L(defun segment (blocks) (let ((min 360) (max 0) sec) (dolist (b blocks) (let ((a (get (car b) :angle))) (when a (setf max (max max a)) (when (> min a) (setf sec (if (null sec) a min)) (setf min a))))) (if (and (zerop min) (> max 90)) (setf min sec max (max 180 max))) (list min max)))9ʁL#KL-!UHVAWAVATASI@ jh 0uHuvHuH~IQIYS L-IA LeMLLމ uH9 0Ov%%HSL-D@ tLLHuLL uH9 0Ov%ff%HSL-@ t} uLLHuMHHuHvHu} HL@uH 0Dv%1%8SL-@ H}@uH 0Ov%Hfff%HSL-d@ tXLuL}L@uH 0Lv%HƠHfffff%HSL-@ t HƠLHuAVuйMff$%xPL-HA[A\A^A_ff7Lfff %,*K*<J576(55f5f+5;HTuH^biDG33036DG33034DG33033DG33030?SECMINu0 ?H?.5? +*? &*$*?*ISEGMENTF6(defun curve-p (seg) (< 30 (- (cadr seg) (car seg))))95#)L-UHVHvHvVHuHv_ u HH)Hptfffff% SL-H@uH 0Ov%HHfff%XSL-Lff'>HH?HHgraph blocks) (let (e (h (worsen-visibility g)) (d (array-dimension g 0))) ; (format t "~a~%" h) (dotimes (i d) (let ((term (remove-duplicates (remove-if #'null (loop for j below d collect (if (and (listp (aref h i j))) (car (aref h i j)))))))) (if (= 1 (length term)) (push (list (car term) (svref v i)) e)))) (let* ((se (sort e #'point< :key #'(lambda (b) (sb-average-centre (fourth (cadr b)))))) (n (car se)) (k (car (last se)))) ; (format t "~a~%" se) (list ; тут бы, конечно, как-то учесть, что могут оба конца пересекаться (if (eq :s (car n)) (reverse (fourth (cadr n))) (fourth (cadr n))) (if (eq :e (car k)) (reverse (fourth (cadr k))) (fourth (cadr k))))))))9+X#'L-UHVAWAVATASMEARHuI4%/c EL-)sHcH) h 0uh 0HuйIffS L-tVH}1IffS L-TVLeuE1Huff%PRL-4HIH^ ؃HVuE1 0 0eH,% eH%eH;%we$%H{HsIASLHu uH9 0Mv%%PSL-@ HuVMLLf%8QL-tu2MLLfffff%8QL-LH~ 0 0eH,% eH%eH;%we$%H{HsHHu_fff%pPL-L@u HHffff%SL-IIsH 0HH_IfS L-lIfS L-TILfff%pSL-GRAPHWORSEN-VISIBILITYNOTREMOVE-IFOqL-umUHVufHvu`HvuZHvuTHvuNHvuHHvIc -;IWfff,u3e!2-)10?u"6N94,CURVE-ENDS^,(WjSVU^NTtSARCIQ%@.?6>t$t#^ss + ~~~^~^q2L)2 {{d{|? h{mz]{\s)[HZMYs-Gs9Eo^sL8NN?SETERMDLOOP-LIST-TAIL-33047DLOOP-LIST-HEAD-33046DLOOP-LIMIT-33045DG33044Hu0^2 {?8w 6w{?{? ??o? j? j?NSF6(defun flatten-blocks (blocks) (reduce #'(lambda (a b) (union a b :test #'equal)) blocks :key #'fourth))9@j#L-uMUHVjRjRIqVIyH^ ؃u/HILE I$%Qf$ͦfffL-uIUHWVjRjRuIiH^ ؃u/HIqLE Iy$%Qf ͦ\]UNION,O)1!(0?O?O"6W9 *,FLATTEN-BLOCKSCADDDRqREDUCE,S!i5`h)Su0?SWYF6+(defun flatten-curve (blocks) (remove-duplicates (let ((term (curve-ends blocks)) (points (flatten-blocks blocks))) (append (car term) (set-difference points (union (car term) (cadr term) :test #'equal) :test #'equal) (cadr term))) :test #'equal :from-end t))9A+#DL-UHVAWjRjRHuIfffffS L-VHuI!fffS L-VL}DYIwVjRjRujRjRDBAwD7Iw-HvVI)H^ ؃HI1AX I9S L- VI)H^ ؃HI1AX IAfffS L-VDIwHv_AXIIS L-HVA1I)H^ ؃utIIQ.0L}(IY$%Qfaͦͦ5HͦfffSY\]XBNFROM-ENDO, *x7 at 5Z u4|at<CVUu0ax? ]x?\FLATTEN-CURVEF6(defun make-block (type width points) (list type width (length points) points))9hO# L-uIUHAPWVuuHu%pSL-Vu MEf$%xPL-ff,N&N,7Fr0?N?N?N_MAKE-BLOCKF6(defun compare (e a b) (cond ((= a b) '=) ((> e (abs (- a b))) '=) ((> a b) '>) ((< a b) '<)))9|p#ž>L-qUHAPAWAVIILL uH9 0Dv%%8SL-@ t IA^A_LL uHH)Hfffff% SL-lIfS L-TH} uH9 0Ov%fffff%HSL-$@ t IA^A_LL uH9 0Ov%f%HSL-@ t IA^A_LL uH9 0Lv%f%XSL-@ t IA^A_þ 0A^A_ffHH?HH0}ix6I1???dPOINT-COMPAREF6&(defun curve-type (points) (let* ((s (car points)) (e (car (last points))) (d (new-point (/ (+ (point-i s) (point-i e)) 2.0) (/ (+ (point-j s) (point-j e)) 2.0))) (q1 (length (remove-if-not #'(lambda (p) (and (> (point-i d) (point-i p)) (> (point-j p) (point-j d)))) points))) (q2 (length (remove-if-not #'(lambda (p) (and (> (point-i p) (point-i d)) (> (point-j p) (point-j d)))) points))) (q3 (length (remove-if-not #'(lambda (p) (and (> (point-i p) (point-i d)) (> (point-j d) (point-j p)))) points))) (q4 (length (remove-if-not #'(lambda (p) (and (> (point-i d) (point-i p)) (> (point-j d) (point-j p)))) points)))) ; (format t "~a ~a ~a q ~a ~a ~a ~a~%" s d e q1 q2 q3 q4) (if (> (point-j s) (point-j e)) (if (> q4 q2) :curve-q4 :curve-q2) (if (> q3 q1) :curve-q3 :curve-q1))))9æ#]OL-YUHAWAVATASMqID<M^LIyfS L-vMD IwVL}DIw_ u Hffff%SL-DHI%0SL-,VMDIwVL}DIw_ u Hffff%SL-HI%0SL-VH}HueH,% eH%eH;%we$%H{HsHHVHH3eH)%eH%eH;%wHCe$%HH-$FFLHFF %hQFMH}LVH~#HH~+HHLLffS L-f%pSL-VHH3eH)%eH%eH;%wHCe$%HH-$FFLHFF %hQFMH}LVH~#HH~+HHLLfffS L-,f%pSL-VHH3eH)%eH%eH;%wHCe$%HH-$FFLHFF %hQFMH}LVH~#HH~+HHLLfffS L-|f%pSL-lVHH3eH)%eH%eH;%wHCe$%HH-$FFLHFF %hQFMH}LVH~#HH~+HHLLfffS L-f%pSL-VMDIwVL}DIw_ uH9 0Ov%ff%HSL-d@ tbH}Hu uH9 0Ov%fff%HSL-,@ tIH0A[A\A^A_IH0A[A\A^A_H}Huȉ uH9 0Ov%ff%HSL-@ tIH0A[A\A^A_IH0A[A\A^A_Ð&ThHH?HH 91 (- (cadr x) (car x))) (every #'(lambda (j) (let* ((a2 (get (car j) :angle)) (z (signum (- 90 a2)))) (and (not (= a1 a2)) (or (zerop s) (zerop z) (= z s))))) g)))))9#L-uMUHVjRjRIqH^ ؃u7HVLEIyI I$%Qfͦfff27DL-UHWVH~II!fffffS L-VHHu@uHH)HDfffff% SL-|I)fS L-dVeH,%X`eH %HeH%XHnfD)yHH9u8HheH%H@HpH-$FFLHFF %hQFM1H}LELVH~#LF+HH~3HVuMuARjRjRjA.0H}Huй I94%/c fffuL-eH%HHeH%HeH%X$%PHH?HH :key #'third))9*C#LL-UHVAWAVATASjRjR 0 0eH,%X eH%XfD)8fD)xeo<%H8HheH%HH@HxHpHIAWMYIaH^ ؃HHuIiS L-LID؃fMcLL؃LOMLDK AL-H 0eH,% eH%eH;%we$%H{HsHLff%pPL-HL~M[A [HuHvHeH%HHeH%HeH%X1Mf$%xQL-\IqfffffS L-DVIyH^ ؃uoHVIH^ ؃u^HIAXL]LeLuL} I$%Qffͦͦͦfff L-UHVAWAVATASHuIYfffS L-IafS L-@  Hufff%pSL-HHIiS L-l1LEIqfffS L-LIYfS L-4IafS L-@ Hufff%pSL-HHIiS L-H}IqffffS L-IYfS L-IafS L-@ W 0 0eH,%X eH%XfD)8fD)xeo<%H8HheH%HH@HxHpHIAWMyHuIS L- ID؃McLL؃LOLDK AL-H 0eH,% eH%eH;%we$%H{HsHLff%pPL-tHL~M[A [HuHveH%HHeH%HeH%XHA[A\A^A_Hu2Hv(HvVHuHvHvHvVHuHvHvVHuIS L-_IS L-l_AXIfffffS L-LH 0eH,% eH%eH;%we$%H{HsHA[A\A^A_ff&=OfffKM?%FIXNUM-FLOORSUBSEQ,L-UHVAWHuIYffS L-ILIafffS L-HvVDIw_IiffS L-l@ tLIqS L-LILIyfffS L-,VHuuVHvuPHvuJH~LAXA_Ic ffTgfff^^2h`,/10( 7W7]gzy7fex7Tjw07?"6l9t2CURVE-BLOCKSkYp`,10>9fb|z9aqy8\eS[~)~5~\D$^S^\^e^q^wx^9N<BMDG33104DG33106DG33105DG33103DG331020  ? ?"6l9=n2<N  q, !(!@}DG33100DG33109DG33101DG33099DG33098u0 S i}?vt?loF6T(defun merge-blocks (blocks) (mapcar #'(lambda (g) (make-block (caar g) (cadar g) (sort-rect (caar g) (flatten-blocks g)))) (group #'block-extension-p blocks :sorter #'(lambda (a b) (> (third a) (third b))) :every #'(lambda (g e) (let ((s (segment (cons e g)))) (> 90 (- (cadr s) (car s))))))))9T#ǽ=L-UHVAWAVATAS 0 0eH,%X eH%XfD)8fD)xeo<%H8HheH%HH@HxHpHIAWMjRjRIH^ ؃+HVuAMII 0IfffS L-,ID؃McLL؃LOLDK AL-H 0eH,% eH%eH;%we$%H{HsHLff%pPL-HL~M[A [HuHveH%HHeH%HeH%XHA[A\A^A_ͦfff'L-UHAWIDIwHvVDIwHvHvVDIwHvVLI1ffffS L-D_I9S L-,_AXA_IAc ,?RdwYp`,Ww/VCUw:B?v%.>$0"6p9X,MERGE-BLOCKS+8L-UHWVHuHvHvu}HvVHuurHvulHvufHv_ uH9 0Ov%ff%HSL-\ff,>Q_m,'M{&L0??"6p9"@(,q74L-UHWVHHueH,% eH%eH;%we$%H{HsH޹IfffS L-VHvHvVHuHv_ u HH)Hptfffff% SL-,H@uH 0Lv%HHfff%HSL-ffmHH?HH 3 ; поставить параметр (length (set-difference (fourth (car blocks)) occ :test #'equal)))) (mount-blocks (cdr blocks) skcolb occ) (mount-blocks (cdr blocks) (push (car blocks) skcolb) (union (fourth (car blocks)) occ :test #'equal)))))9#:L-UHwt I 0IHH 0AWAVATIIMA uLA\A^A_Ic DFIw<HvI;D$IwHvH~@uH 0Dv%H%8SL-@ jRjRDIwHvHvHvvIH^ ؃HIM IfffS L-\@ jRjRDIIw?Hv5Hv+Hv!vIH^ ؃ HIM IS L-f%pSL-H}*DMGLLA\A^A_lDIwVDIeH,% eH%eH;%we$%H{LsHIVjRjRDWIwMHvCHv9Hv/vIH^ ؃HIM IfffffS L-l_AXA\A^A_Xh{ /ASkͦͦj .@Xͦs\]?SUBSETPBX,I4haQmQ jfj}thjebjad`T'_3W^7L?Kd d hihnhwh{|OhFZIO8E?OCC?SKCOLBu0 IIItMOUNT-BLOCKSF6&(defun blk-rel (a b) (let ((ep (/ (min (sb-length (fourth a)) (sb-length (fourth b))) 5))) (list (if (eq a b) (car a) (cross-relation a b)) (point-compare ep (first (fourth a)) (first (fourth b))) (point-compare ep (first (fourth a)) (car (last (fourth b)))) (point-compare ep (car (last (fourth a))) (first (fourth b))) (point-compare ep (car (last (fourth a))) (car (last (fourth b)))))))9#f_L-MUHAWAVATASMIID-Iw#HvHvHvIfffS L-tVDIvHvHvHvIS L-IH}L uH9 0Lv%%XSL-@ tHuLHHH(fff%0SL-IM9uDBIw#LLIfffffS L-tVDIwHvHvHvHvVDIvHvHvHvHv_MLfS L-VDIwHv}HvsHviHvVD]IvSHvIHv?HvI fffS L-Hv_MLS L-VDIwHvHvHvI S L-\HvVDIvHvHvHvHv_MLfffS L-VDaIwWHvMHvCHvI S L-t#HvVDIv HvHvHvI ffffS L-Hv_MLS L-V(MEfff$%xPL-A[A\A^A_ff)<N`T 2]pEXj|-@Rde)^,)VOVa-,a-s-x-v~E,[HZOYE0GE5FE;E]D. ]]\D2OmiTizOTqy)2$WKU)r4>DG33150DG331490 OV 2?2)V)VwBLK-RELF6 (defun image->blocks (img) (curve-blocks ;mount-blocks (mount-blocks ;curve-blocks (merge-blocks (haf-transform img)))))9#L-ueUHVIfffS L-IfS L-IfS L-Ic fff quo,l\>D_,sIMG0?lyIMAGE->BLOCKSF6(defun blocks->graph (blocks) (make-graph #'blk-rel blocks))9<# L-u5UHVIYH^ ؃u#HHuIac ͦfffx,=;)*4u0?=|OF6(defun graphicalize (image) (blocks->graph (image->blocks image)))9@B# L-u5UHVIQfffS L-IYc fff{O,<A,+@0?<}GRAPHICALIZEF"6(defparameter *overlay* nil)9@'?*OVERLAY*F6(defun mklist (obj) (if (listp obj) obj (list obj)))94#L-u]UHAWIDuLA_þ 0eH,% eH%eH;%we$%L{HsHA_Ðfff,d3'd(2 #?OBJ0d?MKLISTF6g(defun interleave (fun args prolist &rest prolists) "такая идиома уже есть, называется alexandria:map-product" (if (null prolist) (list (apply fun (reverse args))) (apply #'append (mapcar #'(lambda (elt) (apply #'interleave fun (cons elt args) (car prolists) (cdr prolists))) prolist))))9Ag#iLL- H~HlHlEUHHMEfff$%QL-AWAVATAS} HuVHuIAfffffS L-|H]1Mfff$%xQL-\؃LOkLDK fffffAL-4HH 0eH,% eH%eH;%we$%H{HsHA[A\A^A_ÿ 0 0eH,%X eH%XfD)8fD)xeo<%H8HheH%HH@HxHpHIAWH HCeH)%eH%eH;%wHCe$%HH-$FFLHFF %hQFMIH}LELMLVH~#LF+LN3HH~;HIL]D؃McLL؃LOLDK ffAL-H 0eH,% eH%eH;%we$%H{HsHLff%pPL-dHL~M[A YHuHvHeH%HHeH%HeH%X1Mf$%xQL- L]LeLuL}IQ$%Qff (fffL- Hl$Hl$EAPWVjRjRuH}HueH,% eH%eH;%we$%H{HsHVHuuNvHuuEHvMf$%xQL-\I$%Qffizfff4,!bvSaevDR(d4CPROLISTS0?!?!?!?!"69+c,4=N,Tfed^^cT^DG33171DG33173DG33172DG33170DG33169?PROLIST0  ?ki?T?T?T?T49такая идиома уже есть, называется alexandria:map-productF6g(defun worsen-visibility (graph) (let ((tmp (make-array (array-dimensions graph)))) (dotimes (i (array-dimension graph 0)) (dotimes (j (array-dimension graph 1)) (setf (aref tmp i j) (car (aref graph i j))))) tmp))9G#jL-AUHAWAVATASILIIfffS L-HǰIQffS L-VL1IYfffS L-VE1Huf%PRL-lHLHIYfffffS L-blacks i))))9@M#L-uUUHWVIqfffS L-H}IyffffS L-Ic fff5>,\LL+K,9J0?\?\?SHRINKF"6J(defparameter octogonal-skeleton #(#2A((0 0 0 ) (nil 1 nil) (1 1 1 )) #2A((nil 0 0 ) (1 1 0 ) (nil 1 nil)) #2A((1 nil 0 ) (1 1 0 ) (1 nil 0 )) #2A((nil 1 nil) (1 1 0 ) (nil 0 0 )) #2A((1 1 1 ) (nil 1 nil) (0 0 0 )) #2A((nil 1 nil) (0 1 1 ) (0 0 nil)) #2A((0 nil 1 ) (0 1 1 ) (0 nil 1 )) #2A((0 0 nil) (0 1 1 ) (nil 1 nil))))9ց'OCTOGONAL-SKELETON8          8         8         8         8         8         8           8         F"6C(defparameter pruning-set #(#2A((0 0 0 ) (0 1 0 ) (0 nil nil)) #2A((0 0 0 ) (0 1 0 ) (nil nil 0 )) #2A((0 0 0 ) (nil 1 0 ) (nil 0 0 )) #2A((nil 0 0 ) (nil 1 0 ) (0 0 0 )) #2A((nil nil 0 ) (0 1 0 ) (0 0 0 )) #2A((0 nil nil) (0 1 0 ) (0 0 0 )) #2A((0 0 nil) (0 1 nil) (0 0 0 )) #2A((0 0 0 ) (0 1 nil) (0 0 nil))))9I'PRUNING-SET8       8       8        8       8      8       8       8       F"6(defparameter horizontal-lines #2A((-1 -1 -1) ( 2 2 2) (-1 -1 -1)))9S'?HORIZONTAL-LINES8        F"6(defparameter vertical-lines #2A((-1 2 -1) (-1 2 -1) (-1 2 -1)))9Q'?VERTICAL-LINES8        F"6(defparameter sobel-gx #2A((-1 0 1) (-2 0 2) (-1 0 1)))9K'SOBEL-GX8        F"6(defparameter sobel-gy #2A(( 1 2 1) ( 0 0 0) (-1 -2 -1)))9K'SOBEL-GY8        F6C(defun check-pixel (image i j selt y g fixel) (if (not (aref selt y g)) t (if (array-in-bounds-p image i j) (= (aref image i j) (aref selt y g)) (if fixel (= fixel (aref selt y g))))))9 @#-L-8EHl$(Hl$(EVAWAVATIML}MLLfffff%8QL-@ u .0A\A^A_LEH}HuIaffS L-|@ tbLEH}Hu%8QL-\VMLL%8QL-D_ uH9 0Dv%f%8SL-A\A^A_À} tRMLLff%8QL-H}؉ uH9 0Dv%fffff%8SL-A\A^A_þ 0A\A^A_,.Q0_QRQD tw_Vs.R4I.L9HFIXEL9SELT0?.Q .Q.Q.Q?*Q?*Q?*Q CHECK-PIXELF6S(defun check-structuring-element (image i j selt fixel y g) (if (= y (array-dimension selt 0)) t (if (check-pixel image (+ i y) (+ j g) selt y g fixel) (if (= (+ 1 g) (array-dimension selt 1)) (check-structuring-element image i j selt fixel (+ 1 y) 0) (check-structuring-element image i j selt fixel y (+ 1 g))))))9 RyiQ&jP jODGN   &U|&T&m5B`5TG_9 0 5y5y?5y5y?1y?1y 1yCHECK-STRUCTURING-ELEMENTF6(defun apply-structuring-element (selt image &key origin (fixel 0) (nvalue 0)) (let ((oi (if origin (car origin) (1- (ceiling (/ (array-dimension selt 0) 2.0))))) (oj (if origin (cdr origin) (1- (ceiling (/ (array-dimension selt 1) 2.0))))) (tmp (make-array (array-dimensions image)))) (dotimes (i (array-dimension image 0) tmp) (dotimes (j (array-dimension image 1)) (if (check-structuring-element image (- i oi) (- j oj) selt fixel 0 0) (setf (aref tmp i j) nvalue) (setf (aref tmp i j) (aref image i j)))))))9 #{qLL-H~HlHlEUHE1HMEf$% QL-AWAVATASLe} u1Hu؀} u1HuȀ} tHumHvvH}1IfS L-THI%0SL-<IfS L-$@u H H%SL-V} tHu<HvyH}HIS L-HI%0SL-IfS L-@u HH%SL-dVLIffffS L-DHǰIffS L-$IL1IfS L-VE1Huf%PRL-HLHIfffffS L-VE1Huf%PRL-H!jRjRATLHu uHH)H/f% SL-dVLHu uHH)HY% SL-4VuLE118IffffS L- @ LMLHuȉ؃\{RH{GH{9A7@5L;C#3HC+H9.HIH<LC fffff% RL-tMLLfff%8QL-TLMLۉ؃{H{H{A@L;C#HC+H9HIH<LC fff% RL-L@u HzHffff%SL-ILHu%hSL-@ HL@u HH%SL-LILHu%hSL-4@ GLHA[A\A^A_fzHH?HH0??IMAGE-EQUALF6=(defun apply-se-set (sset image &key origin (fixel 0) (nvalue 0) (si 0)) (if (>= si (array-dimension sset 0)) image (apply-se-set sset (apply-structuring-element (aref sset si) image :origin origin :fixel fixel :nvalue nvalue) :origin origin :fixel fixel :nvalue nvalue :si (+ 1 si))))9!|=#CL L-H~HlHlEUHE1HMEf$% QL-AWAVL}} u1Hu؀} u1HuȀ} uE1LuL1IffffS L-dL uH9 0Mv%%PSL-<@ t HuA^A_jRjRAWjRjRLLf%SL- VuA!uA)LEI1Huȹ@I9ffffS L-VA!uA)uA1L@uHpJHffff%SL-IALELuL}PL$%QffHH?HH@+,=7< L-uIUHAPWVLEH}HuIafffffL-I;i 0Dv%ff:o,N*<)0?N?N?N"699$N@+,=q,&76Qi05P*0??9=F6(defun realize-vertices (groups) (let (res) (loop for g in groups for n from 0 do (dolist (p g) (push (cons p n) res))) (nreverse res)))9$]#@L-iUHVAWAVATASA 0h 0uE1HuȉA@  HuHvHuHuHvHuL]D؃MceH,% eH%eH;%we$%LcL{HeH,% eH%eH;%we$%H{LsIM[A wHuȉ@ tKHuHvHuHuHvHuL@uHpeHfff%SL-IHLA[A\A^A_Ic f2hHH?HHlines (graph) (let (lines xpoints ypoints) (dotimes (i (array-dimension graph 0)) (let ((y0 (list 0 i 0)) (y1 (list 0 i 1)) (x0 (list 1 i 0)) (x1 (list 1 i 1))) (push y0 ypoints) (push y1 ypoints) (push x0 xpoints) (push x1 xpoints) (push `((,y0 ,x0) (,y1 ,x1)) lines))) (let ((points (append (realize-vertices (sort-vertices xpoints graph)) (realize-vertices (sort-vertices ypoints graph))))) (sort (mapcar #'(lambda (line) (mapcar #'(lambda (end) (mapcar #'(lambda (a) (cdr (assoc a points :test #'equal))) end)) line)) lines) #'(lambda (a b) ; заменить на point< ? (or (< (car a) (car b)) (and (= (car a) (car b)) (< (cadr a) (cadr b))))) :key #'car))))9$#PDL-UHVAWAVATASh 0h 0h 0H}1IfffS L-VE1Huf%PRL-HjAWjMfffff$%xPL-lVjAWjMfffff$%xPL-DVjAWjMfffff$%xPL-VjAWjMfffff$%xPL-IL]LuH}HueH,% eH%eH;%we$%H{HsHHuHueH,% eH%eH;%we$%L[HsHHuHueH,% eH%eH;%we$%LsHsHHuHueH,% eH%eH;%we$%LcHsHHuuAVM%f$%xPL-VASATME$%xPL-VMefff$%xPL-HHueH,% eH%eH;%we$%H{HsHHuHL@u HHff%SL-$ILHu%hSL- @ oHH}HuI!fffS L-I)fS L-VH}HuI!S L-I)fS L-_I1S L-tVjRjR 0 0eH,%X eH%XfD)8fD)xeo<%H8HheH%HH@HxHpHIAWHH3eH)%eH%eH;%wHCe$%HH-$FFLHFF %hQFM9H}LVH~#HH~+HIL]D؃uMcLL؃LO\LDK AL-LH 0eH,% eH%eH;%we$%H{HsHLff%pPL-HL~M[A \HuHvHeH%HHeH%HeH%XVIAH^ ؃HIIMQL]LeLuL} IY$%QHH?HHLINESC,\DG33350DG33352DG33351DG33349DG333480  ? sq??"6B9%]CC,DG33346DG33355DG33347DG33345DG33344U0  ? sq??"6B9$CCq6L-IUHAWAVIID4IwVD(Iv_ uH9 0Lv%%XSL-@ DIwVDIv_ uH9 0Dv%%8SL-<@ txDIwHvVDIvHv_ uH9 0Lv%%XSL-A^A_þ 0A^A_A^A_f2vfff,S5vMVBo{rzv[nfmv^el9L2EDK1<C0SS"6B9%"@,D,Agn{D`Cs=t=\<W$i,?<ml; : o3 WWDG33342DG33358DG33343DG33341DG33340fcdeDG33339?YPOINTS?XPOINTSLINES0   p!lC?CC?  ?P?M?,? '? "?BDF6"(defun lines->svg-path (zoom lines) (let (segs) ; поставить сюда T для кривых? (dolist (line lines) (push `(:M ,(* zoom (cadar line)) ,(* zoom (caar line))) segs) (push `(:L ,(* zoom (cadadr line)) ,(* zoom (caadr line))) segs)) (nreverse segs)))9%J"#[L-IUHVAWAVATASIA 0L]D؃#MsADIvHvHvLff%(SL-lVDIvHvL%(SL-4VMfff$%xPL-HeH,% eH%eH;%we$%H{LcIADXIvNHvDHv:HvL%(SL-|VDIvHv HvLfffff%(SL-,VMfff$%xPL- HeH,% eH%eH;%we$%H{LcIM[A LA[A\A^A_Ic /I\n*=Oafff-2, T&!9T &9k #+ #**sB#BIIUDG33376?SEGSE?ZOOM0B+ *9 &T? T TFLINES->SVG-PATHF6(defun image->lines (image) (graph->lines (graphicalize image)))9%@# L-u5UHVIQfffS L-IYc fff~D,<?,*>0?<HIMAGE->LINESF6(defun lines->image (lines) (instantiate-rectangle (render-svg-path (lines->svg-path 5 lines))))9%b#L-uUUHVH(HuIqfS L-IyfS L-Ic fffG0>,\aL5`4F_E0?\J?LINES->IMAGEF6(defun redraw (image) (instantiate-rectangle (render-svg-path (lines->svg-path 5 (image->lines image)))))9%o#L-umUHVIfffS L-H(IffS L-IfS L-Ic fffIG0>,tnd3mLDl,Wk0?tK?REDRAWF6(defun assignment (cost-mx &key (out *standard-output*)) "Solve the assignment problem using Munkres' algorithm \(AKA Hungarian Algorithm, AKA Bipartite Minimum-Weight Matching). Returns the total cost and two assignment vectors: X->Y and Y->X." (loop :with x-count = (array-dimension cost-mx 0) :and y-count = (array-dimension cost-mx 1) ;; tentative least weights ("D label"): :with x-tlv = (make-array x-count :initial-element nil) :and y-tlv = (make-array y-count :initial-element nil) :and x-matching = (make-array x-count :initial-element nil) :and y-matching = (make-array y-count :initial-element nil) :and s-x = (make-array x-count :element-type 'bit) :and s-y = (make-array y-count :element-type 'bit) :and x-next = (make-array x-count :initial-element nil) :and y-next = (make-array y-count :initial-element nil) :and cost = 0 ;;:and eps = (loop :with min :and max :for i :from 0 :to (1- x-count) :do ;; (loop :for j :from 0 :to (1- y-count) ;; :for cost = (abs (aref cost-mx i j)) :do ;; (when (or (null min) (< cost min)) (setq min cost)) ;; (when (or (null max) (> cost max)) (setq max cost))) ;; :finally (return (* (/ (- max min) (+ max min)) ;; ))) :for iteration-count :upfrom 1 :do (when out (format out "~&~S(~:D): ~S~% ~S~% ~S~%" 'assignment iteration-count cost x-matching y-matching)) ;; s-x == all free X vertices (dotimes (i x-count) (if (svref x-matching i) (setf (sbit s-x i) 0 (svref x-tlv i) nil) (setf (sbit s-x i) 1 (svref x-tlv i) 0))) (fill y-tlv nil) (fill x-next nil) (fill y-next nil) (loop :while (find 1 s-x) :do (fill s-y 0) (dotimes (i x-count) ; for all X (unless (zerop (sbit s-x i)) ; in Sx (let ((dx (svref x-tlv i))) (dotimes (j y-count) ; for all Y (unless (eql j (svref x-matching i)) ; (x,y) not in M (let ((dy (svref y-tlv j)) (ndy (+ dx (aref cost-mx i j)))) (when (or (null dy) (< ndy dy)) (setf (svref y-tlv j) ndy (sbit s-y j) 1 (svref y-next j) i)))))))) (fill s-x 0) (dotimes (j y-count) ; for all Y (unless (zerop (sbit s-y j)) ; in Sy (let ((i (svref y-matching j))) (when i ; (x,y) in M (let ((dx (svref x-tlv i)) (ndx (- (svref y-tlv j) (aref cost-mx i j)))) (when (or (null dx) (< ndx dx)) (setf (svref x-tlv i) ndx (sbit s-x i) 1 (svref x-next i) j)))))))) ;; free vertex with min TLV (let ((min nil) (pos nil) (weight 0) (len 0)) (dotimes (j y-count) (unless (svref y-matching j) (let ((dy (svref y-tlv j))) (when (or (null min) (< dy min)) (setq min dy pos j))))) (unless min (return-from assignment (values cost x-matching y-matching))) ;; augment M with the path associated with POS (loop :for i = (svref y-next pos) :for j = (svref x-next i) :do (setf (svref y-matching pos) i (svref x-matching i) pos) (incf weight (aref cost-mx i pos)) (incf len) :unless j :return nil :do (setq pos j) (decf weight (aref cost-mx i j)) (incf len)) (unless (= min weight) ; (< (/ (- min weight) (+ min weight)) eps) (warn "~S: rounding error ~5F * float-epsilon" 'assignment (/ (- min weight) (+ (abs min) (abs weight)) (etypecase min (short-float short-float-epsilon) (single-float single-float-epsilon) (double-float double-float-epsilon) (long-float long-float-epsilon))))) (when out (format out "~& => augmenting path: len=~:D weight=~S~%" len weight)) (incf cost weight))))9%Г#&LL-H~HlHlEUHE1HMEff$% QL-AWAVATAS} u;IHK*1eH; %@CeH%HH4BHDs0HuH}1IffS L-LVH}HIffffS L-$VL}jRjRhAWh 0h 0h 0h.0h 0A 0 0 0PIS L-VL}jRjRhAWh 0h 0h 0h.0h 0A 0 0 0PIS L-VL}jRjRhAWh 0h 0h 0h.0h 0A 0 0 0PIS L-4VL}jRjRhAWh 0h 0h 0h.0h 0A 0 0 0PIS L-VL}jRjRhAWh 0h 0h 0h 0h 0A 0 0 0PIS L-VL}jRjRhAWh 0h 0h 0h 0h 0A 0 0 0PIS L-DVL}jRjRhAWh 0h 0h 0h.0h 0A 0 0 0PIS L-VL}jRjRhAWh 0h 0h 0h.0h 0A 0 0 0PIS L-Vjj} tEjRjRuAAhLpH}Hu8IfffS L-TLuE1L%PRL-LLމ H9 0Lv%f%XSL-@ LELLDA@x @v I@HHH9i f% RL-4LEHDA@9 A7 I@HHI9* LHI@LELLDA@ @ I@HHH9 % RL-HL@H Hff%SL-TILH`fff%hSL-4@ H%A 0A 0E1juE1HX%PRL-HQH}G A HGHHI9v Jt?@ H}GP AN HGHHI9A Bt?A GHPLމ H9 0Lv%fffff%XSL-@  LPMHL@H Hfffff%SL-ILHXfff%hSL-@ HA (puuL]LeLuL}$%PA 0h 0HxG| Az HGHHI9m N|7H}GQ AO HGHHI9B Jt?HXLELLDA@ @ I@HHH9 % RL-tLELLDA@@I@HHH9fff% RL-LELL%8QL-VLHP Hfff%SL-VIHH`@HHff%SL-H`X  HLXLELHX%8QL-LVLHP HH)H~ffff% SL- VIHH`@HHff%SL-H`gHLL H9 0Ev%ffff%@SL-@ ^LL HH)Hi% SL-DVL޹IffffS L-$VLIffffS L-_ HZffff%SL-VMD IVDAG) I-ILIfff%@QL-d 0_AXIfS L-DIMIfffS L-} .jRjRuM H`L IS L-HpL Hfff%SL-HpHHh@HH%SL-lHh 0H`A[A\A^A_fa͓׶4>hضض&HH?HHf׶HH?HH augmenting path: len=~:D weight=~S~%,X _l [~w0v<jD!lr-,D)7D ;  <{ < 7. x 0 !   jY tm t j R  Q b P  O ; N  , ! +  X  G | x F x E  x D D x  C N x 5 B . t A v t @ . v 8 v . 8 | l { N ? N  Z | e q \Z L^  ]  \  [ E Z  OY > X  W >D>DYhE-G,>\9E4".D3DV7Kagg{u|nuDG33413DG33411DG33412DG33409DG33410DG33408?WEIGHTJ?NDXDG33406?NDYDG33404DG33402DG33398DG33392?ITERATION-COUNTCOST?Y-NEXTDDIMS?X-NEXTDDIMS?S-YDDIMS?S-XDDIMS?Y-MATCHINGDDIMS?X-MATCHINGDDIMS?Y-TLVDDIMS?X-TLVDDIMS?Y-COUNT?X-COUNT?OUT?COST-MX00?,?*?,5<?*<?(DD?* j?( j?& _ _ _ _ . x ' x D x  ?& > 7 " ?* ?( bZ ?&_Z 4?$a?"_? ]\?  ?q?m!l???}1|?-,????TLNE9Solve the assignment problem using Munkres' algorithm (AKA Hungarian Algorithm, AKA Bipartite Minimum-Weight Matching). Returns the total cost and two assignment vectors: X->Y and Y->X.F6V(defun make-cost-matrix (a b change-cost-fn add-cost-fn) (let* ((al (length a)) (bl (length b)) (sl (+ al bl)) (m (make-array (list sl sl)))) (dotimes (i al) (dotimes (j bl) (setf (aref m i j) (funcall change-cost-fn (svref a i) (svref b j)))) (dotimes (j al) (setf (aref m i (+ bl j)) (if (= i j) (funcall add-cost-fn (svref a i)) most-positive-fixnum)))) (dotimes (i bl) (dotimes (j bl) (setf (aref m (+ al i) j) (if (= i j) (funcall add-cost-fn (svref b i)) most-positive-fixnum))) (dotimes (j al) (setf (aref m (+ i al) (+ j bl)) 0))) m))9*V#B>!L- Hl$Hl$EAPWVAWAVATASHu%pSL-VHufff%pSL-VH}Hu u Hffff%SL-|VuuMfffff$%xPL-THǰI ffS L-4IuE1Hufff%PRL-HLeE1Lfffff%PRL-HAVAWH}uGAHGHHI9Jt7VH}uGAHGHHI9Jt?_H]؃LOLDK AL-4_AXLۉ؃{H{xH{jAh@fL;C#dHC+H9_HIH<LC % RL-L@u H2Hffff%SL-ILL%hSL-l@ LeE1Lffff%PRL-DHAVH}L u H fff%SL- VLL uH9 0Dv%fff%8SL-@ tlH}uGAHGHHI9Jt7H]؃LOLDK AL-l H_AXLۉ؃{H{H{A@L;C#HC+H9HIH<LC fff% RL-L@HVHfffff%SL-ILL%hSL-@ GL@HXHfff%SL-LILHu%hSL-4@ HuE1Huf%PRL- HLeE1Lfffff%PRL-HH}L Hfffff%SL-VAWLL H9 0Dv%ff%8SL-l@ twH}GAHGHHI9Jt7H]؃LOLDK fffAL- H_AXLۉ؃{H{H{wAu@sL;C#qHC+H9lHIH<LC % RL-dL@H:Hfffff%SL-,ILL%hSL-@ /LeE1Lffff%PRL-HALHu Hfffff%SL-VLHu H3fffff%SL-tH1AXD؃cA{XI{MI{?A=@;M;C#9IC+H94HIH<MC ID8L@HH%SL-ILL%hSL-@ L@HHfff%SL-lILHu%hSL-T@ GHLHA[A\A^A_fHH?HHE-5L!a!`DG33428DG33426DG33424DG33422DG33420DG33418M?SL3?AL?ADD-COST-FN?CHANGE-COST-FN0^ ^ ?~ ~ ? ??U?=?)?)?)?)QMAKE-COST-MATRIXF6?(defun regraph (graph) (let ((v (make-array (array-dimension graph 0)))) (dotimes (i (array-dimension graph 0)) (let (e) (dotimes (j (array-dimension graph 0)) (if (and (/= i j) (aref graph i j)) (push (aref graph i j) e))) (setf (svref v i) (cons (aref graph i i) (apply #'vector e))))) v))9*?#L-UHAWAVATASIL1I fS L-HǰIffS L-VL1I fffS L-VE1Huf%PRL-lHqA 0L1I ffffS L-]O7|65i 44!3 ::W::<.GDG33435DG334330?  ? }?]$ $TREGRAPHF6(declaim (inline edge-cost))9*@L-u"UHI9IAc ff,EDGE-COST,VF6(defun edge-cost (a b) (if (equal a b) 0 10))9*-# L-uAUHWVH}HuIYfffS L-@ t1HPf\,G,:&0?G?GXW,,,,W,W,,\ F6(declaim (inline edge-price))9*@L-u"UHI9IAc ff,EDGE-PRICE,YF6(defun edge-price (a) (declare (ignore a)) 10)9+.#L-uUHVHPfffff,0?[Z,,,Z,,?IGNORE,Z F64(defun vertex-cost (a b) (+ (if (eq (unify-type (car a)) (unify-type (car b))) 0 10) (assignment (make-cost-matrix (cdr a) (cdr b) #'edge-cost #'edge-price) :out nil)))9+#@L-MUHWVHu=HvIfS L-VHuHvIffS L-_H9u1HPVjRjRHuvHuHvVIH^ ؃HVI H^ ؃H_AX IfffS L-II 0I!ffS L-_ uHpN%SL-ffIͦͦHH?HH,6=0?V?V\VERTEX-COSTF6(declaim (inline vertex-price))9+>@L-u"UHI9IAc ff,VERTEX-PRICE,^F6(defun vertex-price (a) (case (car a) (:dot 10) (t 100)))9+F@9# L-u5UHVu.vHuI;Yu HPH fff,=8DG334660?=?=`_,,,_,_,?CASE,, , dF6(defun graph-cost (a b) (assignment (make-cost-matrix a b #'vertex-cost #'vertex-price) :out nil))9+Vd#L-UHWVjRjRuIH^ ؃ugHVIH^ ؃uVH_LE IffS L-II 0Ic f$ͦ=ͦfff]_SMN,co&Y6NJX5tree (lst) (grow (make-instance 'burkhard-keller-tree) (mapcar #'(lambda (p) (cons (graph43 (cadr p)) (car p))) lst) #'graph-cost :key #'car))9+|#HL-UHVAWAVATASjRjRI9HvVI9H]؃LOLDK ffffAL-HV 0 0eH,%X eH%XfD)8fD)xeo<%H8HheH%HH@HxHpHIAWMAL]D؃8McLL؃LOLDK fffffAL-H 0eH,% eH%eH;%we$%H{HsHLff%pPL-HL~M[A UHuHvHeH%HHeH%HeH%XVIIH^ ؃ulHVIQH^ ؃u[HIYAXL]LeLuL}(Ia$%Q=ͦͦ L-u&UHIA.0IIc ffff?COEDENBURKHARD-KELLER-TREEL-UHVHvu|HvIS L-VHuuZHv_eH,% eH%eH;%we$%H{HsHff'Qd,/M_'.L&5%0?"6e9+@0,GRAFS->TREEbq?fGROW,iN!h%JDG33479DG33484DG33480DG33478DG334770 k ??ehF6(defun add23 (tree image char) (inoculate tree (cons (graph43 (graphicalize image)) char) #'graph-cost :key #'car))9+@y#!L-UHAPWVjRjRuHuIffS L-I fS L-HHueH,% eH%eH;%we$%H{HsHVIH^ ؃uDHVIH^ ؃u3HI!AX(I)$%Qͦͦfff~dbq?fINOCULATE,!xrw`m5_W;Ytree (name) (grafs->tree (with-open-file (f name) (read f))))9+J#.L-MUHVh 0h 0MM=$%Tfff=L-} t2} 0Dv%IiLEIqfffS L-fffL-tHuIyffffS L-THuVIfffS L-4HV.0Hu^HM$%@PL-eH%HeH%0HKHHPHHSeH%0yHxeH4%?s HHIc h,XIH&H?GDG33497DG33496NAME0??H?H?Xl?FILE->TREEF6(defun comb-char-list (lst) (sort ; (let ((l (remove-duplicates lst :test #'(lambda (a b) (and (char= (car a) (car b)) (zerop (graph-cost (graph43 (cadr a)) (graph43 (cadr b))))))) ;)) ; (format t "~a~%" (length l)) ; (sort l #'char< :key #'car))9+#L-UHVjRjRLEIIIffS L-VIH^ ؃uGHVIH^ ؃u6HIAX I$%QffLͦeͦfff]2L-)UHWVHuHv@HVHuHv@H_H9HuHvHvIfffS L-TVHuHvHvIS L-_IS L-H@uH 0Dv%1%8SL-þ 0,?Qmfffdb,5pi.5oi<n[mdliHZiQYi1;Q)0,!(0?5?5"6n9+q,COMB-CHAR-LISTO?CHAR<q,^vE]D3$+_0?noF6H(defun grafs->file (lst name) (let ((*print-pretty* t)) (with-open-file (f name :direction :output :if-exists :supersede :if-does-not-exist :create) (format f "~s" (comb-char-list lst)))))9,!#bL-UHWVAW.0I M5ff$%HPL-h 0h 0MMe$%TffffeL-} t2} 0Dv%ILEȹIfffS L-\fffL-LjRjRuA!A)A1M9IAII8IQS L-HuVVHuIYS L-VL}A txAWHpuGHkVH0u2HpHvHHHHHHH 0Dv%HhHH 0Dv%H@ t?MARMIaHxIi4%/c fL-$AI.0tL 0HxIqffffS L- 0VHM5$%xRL-MMff$%RL-.0Hu1Mm$%@RL-HM$%8PL-leH<%HeH%0HWHHXHH_eH%0yHxeH4%?s ffff%TL-L}$%Pf*PRINT-PRETTY*oE~sPRIN1, <>DG33510DG33509DG33508DG33507qm0?$C?")!? ??F? A? <??pGRAFS->FILEF6N(defun gather-fruit (tree graph &key (cost 150) char) (remove-duplicates (mapcar #'(lambda (p) (let ((c (cdr (tree-fruit (second p))))) (if char c (list (car p) c)))) (sort (gather tree (graph43 graph) #'graph-cost cost :key #'car) #'< :key #'car)) :from-end t :test #'equal :key (if char #'identity #'cadr)))9,SN#LL-H~HlHlEUHE1HMEf$% QL-AWAVATAS} u HưHujRjR 0 0eH,%X eH%XfD)8fD)xeo<%H8HheH%HH@HxHpHIAWHH3eH)%eH%eH;%wHCe$%HH-$FFLHFF %hQFMH}LVH~#HH~+HIjRjRjRjRuHuI ffS L-VIH^ ؃#HVIH^ ؃HI!LE0I)fffS L-4VI1H^ ؃HVIH^ ؃HI!AX I9fffffS L-ID؃McLL؃LOmLDK AL-H 0eH,% eH%eH;%we$%H{HsHLff%pPL-ySET0 d LH#?##?mC? G? 2?xzEreturn a list of all subsets of the given set (represented as a list)F6;(defun part (set) (if (null set) (list nil) (loop for partition in (part (cdr set)) nconc (cons `((,(car set)) ,@partition) (loop for piece in partition for i from 0 collect (nconc `(,(cons (car set) piece)) (subseq partition 0 i) (subseq partition (1+ i))))))))9-;#A;L-UHVAWAVATASM} uH 0 0eH,% eH%eH;%we$%H{HsHA[A\A^A_þ 0VHuCHvfffjL-\VLeп 0 0eH,% eH%eH;%we$%H{HsHVuHuȉ@ HuLfHuHvHuHuVHuH~ 0eH,% eH%eH;%we$%H{HsHeH,% eH%eH;%we$%H{LcHVh 0ME1 0 0eH,% eH%eH;%we$%H{HsHVuDA IwHuMHuVHuH~HueH,% eH%eH;%we$%H{HsH߾ 0eH,% eH%eH;%we$%H{HsHVM1LLfffffS L-Hv4Hv*HvIffS L-L~DIwILL uH9 0Ov%fff%HSL-D@ tLLHuHuHvHuȀ} MASuйM$%xPL-HA[A\A^A_ff5J^p'9dvfff^,)ES_GgdKGpJDG33598DG33597DG33596DG33595DG33592df?SS0vJ G? ,? ) '??HOR-EXTENTF6(defun range-intersection (r1 r2) (if (> (car r1) (car r2)) (rotatef r1 r2)) (if (> (car r2) (cadr r1)) nil (- (min (cadr r1) (cadr r2)) (car r2))))9.#SL-UHAWAVATASIIDIvVDIw_ uH9 0Ov%fff%HSL-@ t MMMMD\IwVDPIvFHv_ uH9 0Nv%fffff%`SL-@ DIvLfDIwL^LLމ uH9 0Lv%%XSL-@ tLLVDIw_ uHH)Hfff% SL-DA[A\A^A_þ 0A[A\A^A_"6 .{HH?HHM"z(=6I4<"5+3DG33605DG33604DG33603DG33602R2R10 @z z }""?RANGE-INTERSECTIONF6(defun range-length (r) (- (cadr r) (car r)))9.-#L-uiUHVubHvu\HvVHuuQHv_ u HH)Hp<fffff% SL-ff2HH?HHsorted-blocks (image) (sort (image->blocks image) #'hor-point< :key #'(lambda (b) (sb-average-centre (fourth b)))))9.#L-uiUHVjRjRHuIfffS L-VIH^ ؃u3III I$%Qff<ͦ{qL-uQUHVuJHvuDHvu>Hvu8HvIc -;,Y,I!+0?Y"6 9.@-,IMAGE->SORTED-BLOCKS,n&T[V5MBO4,A0?n F6(defun choose-char-chains (tree img &key (cost 30)) (let* ((blocks (image->sorted-blocks img)) (n (length blocks))) (mapcar #'(lambda (bs) (let ((w (min 1 (abs (- 1 (/ (apply #'+ (mapcar #'length bs)) n)))))) (mapcar #'(lambda (b) (mapcar #'(lambda (p) (list w (/ (car p) cost) (cadr p))) (gather-fruit tree (blocks->graph b) :cost cost))) bs))) (imagine-boxes blocks))))9/#ULL-qH~HlHlEUHE1HMEf$% QL-AWAVATAS} u HHuHuIfffS L-|V%pSL-lV 0 0eH,%X eH%XfD)8fD)xeo<%H8HheH%HH@HxHpHIAWH HCeH)%eH%eH;%wHCe$%HH-$FFLHFF %hQFMH}LELMLVH~#LF+LN3HH~;HIHuIfS L-dID؃McLL؃LOLDK AL-H 0eH,% eH%eH;%we$%H{HsHLff%pPL-HL~M[A [HuHveH%HHeH%HeH%XHA[A\A^A_fffu!L- Hl$Hl$EAPWVAWAVATAS 0 0eH,%X eH%XfD)8fD)xeo<%H8HheH%HH@HxHpHIAWIH^ ؃IL]D؃McLL؃LOfLDK fAL-H 0eH,% eH%eH;%we$%H{HsHLff%pPL-HL~M[A ZHuHvHeH%HHeH%HeH%X1Mf$%xQL-tIfffffS L-\HHuff%0SL-DH@uHH)Hefff% SL-IfS L-IL@uH 0Ov%HHfff%XSL-@ t HLV 0 0eH,%X eH%XfD)8fD)xeo<%H8HheH%HH@HxHpHIAWH HCeH)%eH%eH;%wHCe$%HH-$FFLHFF %hQFMH}LELMLVH~#LF+LN3HH~;HIL]D؃KMcLL؃LO2LDK fAL-|H 0eH,% eH%eH;%we$%H{HsHLff%pPL-,HL~M[A ZHuHveH%HHeH%HeH%XHA[A\A^A_ͦHH?HH:??ON ; Qs?~s|s?)?)?)?)"69/'@= ,e}6}zDG33623DG33648DG33624DG33622DG33621TuPzk0 ; }}?}}?}?}?e}?T}?T}HF6(defun guess-char-chains (tree img &key (cost 30)) (let ((h (array-dimension img 0)) (w (/ (array-dimension img 1) 6))) (remove-if #'(lambda (c) (some #'null c)) (mapcar #'(lambda (ps) (mapcar #'(lambda (b) (mapcar #'(lambda (p) (list 0 (/ (car p) cost) (cadr p))) (gather-fruit tree (graphicalize (copy-rect (list 0 (floor (* w (1- (car b)))) h (floor (* w (car (last b))))) img)) :cost cost))) ps)) (parth '(1 2 3 4 5 6))))))9/m#aLL-H~HlHlEUHE1HMEf$% QL-AWAVATAS} u HHuH}1I ffS L-|VH}HI ffffS L-THH0%0SL-LINK-CHAINC,6Y! XMW!"LDG33716DG33718DG33717DG33715DG337140  ?vt?6?6"6903Z]INITIAL-VALUE[,r!T,9CHAIN?NEXT0?r?rF6o(defun start-chains (&rest chains) (second (reduce #'(lambda (a b) (list (list (apply #'append (mapcar #'car a))) (append (apply #'append (mapcar #'(lambda (chain) (link-chain (first b) chain)) a)) (second b)))) (append `(((( ,(list 0 0 #\Space) )))) chains) :from-end t :initial-value (let ((e '(0 0 #\Space))) `((( ,e )) ((,e)))))))90VAo#_L-H~HlHlEUHM5fff$%QL-jRjRIVjjh Me$%xPL-H 0eH,% eH%eH;%we$%H{HsH߾ 0eH,% eH%eH;%we$%H{HsH߾ 0eH,% eH%eH;%we$%H{HsH߾ 0eH,% eH%eH;%we$%H{HsHHuIfffffS L-VAI  0eH,% eH%eH;%we$%H{HsH߾ 0eH,% eH%eH;%we$%H{HsHVI  0eH,% eH%eH;%we$%H{HsH߾ 0eH,% eH%eH;%we$%H{HsHVMf$%xPL-tIA.00IfffS L-LuHvuHvfffffL-UHWVAWAVATAS 0 0eH,%X eH%XfD)8fD)xeo<%H8HheH%HH@HxHpHIAWIqH^ ؃IL]D؃McLL؃LO}LDK fffAL-$H 0eH,% eH%eH;%we$%H{HsHLff%pPL-HL~M[A WHuHvHeH%HHeH%HeH%X1M}f$%xQL-|IyfffffS L-dH 0eH,% eH%eH;%we$%H{HsHV 0 0eH,%X eH%XfD)8fD)xeo<%H8HheH%HH@HxHpHIAWHH3eH)%eH%eH;%wHCe$%HH-$FFLHFF %hQFMH}LVH~#HH~+HIL]D؃McLL؃LOhLDK AL-H 0eH,% eH%eH;%we$%H{HsHLff%pPL-HL~M[A \HuHvHeH%HHeH%HeH%X1Mf$%xQL-\IyfffffS L-DVHuHvHv_IS L-VMfff$%xPL-A[A\A^A_ffzͦN L-u1UHWVHuu%H~HuIQc ,8.$'0?8?8"690/START-CHAINSC,&DOcA@k/?DG33736DG33741DG33737DG33735DG33734DG33732DG33738DG33733DG33731DG337300 S i?., 3 Ik? skqk?&?&"690e@], [,<%n<0m|?l|YkHtHSHo@G<CHAINS0?< F6(defun char-cost (freqs l k) (+ 0.2 (* 0.3 (if (not (hash-table-p freqs)) 0 (let ((s (make-string 2))) (setf (char s 0) (char-downcase (third l)) (char s 1) (char-downcase (third k))) (gethash s freqs 1)))) (* 0.5 (/ (+ (second l) (second k)) 2))))90# L-UHAPWVAWAVATHuIafffS L-@ u1HHeH)%eH%eH;%wHCe$%IHuHvHvHv@IIIiLsDfIFHHkI9}LHIDHkLL1MIqffffS L-Hu HvHvHv@IIIiLsDIFHHkI9}LHIDHkLLHMIqffS L- MH}HIyfffS L-Iff%(SL-Iff%SL-VHu"HvHvVHu HvHv_ u Hff%SL-.>L.?,$MMMvMu 4+4IZ|<<vB8R<=QDG33756DG33755DG33754DG33753gFREQS0 ?$?$?$"CHAR-COSTF6X(defun chains->graph (freqs links) (let ((ln (make-hash-table)) (len 0)) (dolist (l links) (setf (gethash (car l) ln) len) (incf len)) (let ((graph (make-array (list len len) :initial-element nil)) (vect (make-string len :initial-element #\Space))) (dolist (l links (values graph vect)) (let* ((c (car l)) (i (gethash c ln))) (setf (char vect i) (third c)) (dolist (k (cdr l)) (setf (aref graph i (gethash k ln)) (char-cost freqs c k))))))))91# L-UUHWVAWAVATASMA1IIfffS L-IjLu}DM~D MGLHuȹIQfS L-tHu@u HHfff%SL-DHuMvA yuuȹMffff$%xPL- IjRjRhAWh 0h 0h 0h.0h 0A 0 0 0PIYffS L-VLEHH %RL-VuHuZvHuMLvLLLfffS L-LVD%IvHvHvH}LEIafS L-HuvHuL~LLLS L-VLELLIifffffS L-_LEH]؃~{tH{iH{[AY@WL;C#UHC+H9PHIH<LC fff% RL-HuHvHu}  HHHHuHvHu} 1uuL]LeLuL}$%PffGZHH?HHGRAPHF6j(defun shortest-chain (freqs &rest chains) (multiple-value-bind (g v) (chains->graph freqs (apply #'start-chains chains)) (string-trim " " (map 'string #'(lambda (i) (char v i)) (diter (dijkstra-shortest-path g))))))91}#ȼ<L-H~HlHlEUHHMEffff$%QL-MARHu1Mmfff$%xQL-IfffffS L-tH}I4%/c ffL-L)sHcH) h 0uHH3eH)%eH%eH;%wHCe$%HH-$FFLHFF %hQFMH}LVH~#HH~+HVHuIfffS L-IfS L-t_MI fS L-TIIc ffff , L-u%UHWVH}HuIAc fffffj,*0?*?*"6-91,SHORTEST-CHAINCSTRINGE ?STRING-TRIM,L-VVtULOUd!&0???L?L-.9F6(defun blank-p (i max left getter) (if (= left 0) nil (if (= i max) t (blank-p (1+ i) max (- left (funcall getter i)) getter))))91#F!L- IHl$Hl$EAPWVAWL}H}@uH 0Ev%1fff%@SL-@ LHu uH9 0Dv%f%8SL-t@ t .0A_jRjRL@u HHff%SL-4VLH]؃LOLDK fAL-H} uHH)Hfff% SL-HHuLEL}ع L$%Q 0A_fHH?HHPbL-u!UHAPWVLEH}Hu$%8Q,(CN0?(?(?("6592/@ ,BLANK-COLUMN-PP1,!,tuSs:tBN%:5ATOL670?!?!?!?!57F6(defun cut-into-lines (rect image &optional (div 40)) (labels ((linec (image rect i i1 lines) (if i (if (= i (third rect)) (reverse (if i1 (push (list i1 (second rect) i (fourth rect)) lines) lines)) (if (blank-line-p image rect i div) (if i1 (linec image rect (1+ i) nil (push (list i1 (second rect) i (fourth rect)) lines)) (linec image rect (1+ i) nil lines)) (if i1 (linec image rect (1+ i) i1 lines) (linec image rect (1+ i) i lines)))) (linec image rect (first rect) i1 lines)))) (linec image (if rect rect (append '(0 0) (array-dimensions image))) nil nil nil)))928B#L-UHt rtAPWVs h 0uɸ 0E@%P} u H@HujRjRHuVu} tHu$^$u$d|r^n^Jm 7\bF  E >5}0=3' [{dxk?q z<BT<sGSE740 2j 2j2j2j?.j?.j"6992FBX,?LINECCUT-INTO-LINES9,`8`:lG~xU}]cxd|470?`?O?O9:BF6`(defun trim-box (rect image) (let* ((start (do ((i (first rect) (1+ i))) ((or (= i (third rect)) (not (blank-line-p image rect i))) i))) (stop (do ((i (1- (third rect)) (1- i))) ((or (> start i) (not (blank-line-p image rect i))) i)))) (if (> start stop) '(0 0 0 0) `(,start ,(second rect) ,(1+ stop) ,(fourth rect)))))92`#+&L-1UHAWAVATASM)IIDM~1L@u HHfff%SL-ID/Iv%HvHvL uH9 0Dv%ffff%8SL-,@ u/MLLLfffffS L-@ 0Dv%@ +LVDIvHvHv@u H{Hfffff%SL-I.L@u HH%SL-TIH}L uH9 0Ov%%HSL-$@ u/MLLLfffffS L-@ 0Dv%@ fLIH}L uH9 0Ov%fffff%HSL-@ tI1HA[A\A^A_uDIv vL@u HHfff%SL-oBH?STOP?START70!:!?:< ):):<TRIM-BOXF6-(defun cut-into-boxes (rect image &optional (tol 1) (space 15)) (labels ((boxec (image rect j j1 s1 boxes) (if j (if (= j (fourth rect)) (mapcar #'(lambda (r) (trim-box r image)) (reverse (if j1 (push (list (first rect) j1 (third rect) j) boxes) boxes))) (if (blank-column-p image rect j tol) (if j1 (boxec image rect (1+ j) nil j (push (list (first rect) j1 (third rect) j) boxes)) (if s1 (if (> (- j s1) space) (boxec image rect (1+ j) nil j (push (list (first rect) s1 (third rect) j) boxes)) (boxec image rect (1+ j) nil s1 boxes)) (boxec image rect (1+ j) nil j boxes))) (if j1 (boxec image rect (1+ j) j1 nil boxes) (boxec image rect (1+ j) j nil boxes)))) (boxec image rect (second rect) j1 s1 boxes)))) (boxec image (if rect rect (append '(0 0) (array-dimensions image))) nil nil nil nil)))935#'L-  H~HlHlEUHt rtAPWV s  h 0u 0C@%GI%PQ} u HHu} u HxHujRjRHuVHuVu} tHu?HuI1fffS L-4I9IAffS L-Vh 0A 0 0 0@II$%Qfffy, |vv!L-@eHl$0Hl$0EAPWVAWAVATAS} Hu8Hv.Hv$HvHvH}؉ uH9 0Dv%fff%8SL-T@  0 0eH,%X eH%XfD)8fD)xeo<%H8HheH%HH@HxHpHIAWHH3eH)%eH%eH;%wHCe$%HH-$FFLHFF %hQFM H}LVH~#HH~+HI} HuvuHuHvHvvuع Mff$%xPL-HHueH,% eH%eH;%we$%H{HsHHuHuI fffS L-ID؃:McLL؃LO!LDK AL-LH 0eH,% eH%eH;%we$%H{HsHLff%pPL-HL~M[A [HuHveH%HHeH%HeH%XHA[A\A^A_jRjRuLEH}Hu I ffffS L-@ } jRjRHuVHuVuuHu@u HHfff%SL-,VHuBvuHu2Hv(Hvvuع M=$%xPL-HHueH,% eH%eH;%we$%H{HsHHuH}A 0L]LeLuL}@L$%Q} H}Huȉ uHH)Hoffff% SL-HHu uH9 0Ov%fff%HSL-@ jRjRHuVHuVuuHu@u HSHfffff%SL-VHuvuHurHvhHv^vuع M$%xPL-$HHueH,% eH%eH;%we$%H{HsHHuH}A 0L]LeLuL}@L$%QjRjRHuVHuVuuHu@u HH%SL-|VA 0H}HuL]LeLuL}@L$%QjRjRHuVHuVuuHu@u HHff%SL- VA 0H}HuL]LeLuL}@L$%Q} tqjRjRHuVHuVuuHu@u HHfff%SL-VLEп 0HuL]LeLuL}@L$%QjRjRHuVHuVuuHu@u HpHfff%SL-$VLEؿ 0HuL]LeLuL}@L$%QjRjRHuVHuVuuHubHvXvLEH}HuL]LeLuL}@L$%Qf7I[mtHH?HH93a@!?BOXECCUT-INTO-BOXESC7, )o8  o D3 @M " x (<l"#q"p"Jo\bDDCX/5&Dmm m:l&*QGW&t]i<BMM^QM3DW3IVDG33810DG33812DG33811DG33809DG33808BOXES?S1J178SPACE0   oMM? M M?)o? )o? )o?)o?)o?)o?)o?)o"6>93Fj?G,BS`nv|}C870???n?n>@9BF6x(defun copy-rect (rect image) (let* ((height (- (third rect) (first rect))) (width (- (fourth rect) (second rect))) (tmp (make-array `(,height ,width)))) (do ((i (first rect) (1+ i))) ((= i (third rect)) tmp) (do ((j (second rect) (1+ j)) (is (- i (first rect)))) ((= j (fourth rect))) (setf (aref tmp is (- j (second rect))) (aref image i j))))))94!Ax#xtL-uUHVAWAVATASID^IvTHvJHvVD>Iv_ uHH)H%% SL-lVDeIv[HvQHvGHvVD;Iv1Hv_ uHH)Hfffff% SL-VuuȹMUfffff$%xPL-HǰIffS L-IDMf`DIvHvVDIvL uHH)H% SL-VL}1DIvHvL uHH)Hffff% SL-VLELLfffff%8QL-_LELۉ؃{H{H{A@L;C#HC+H9HIH<LC ffff% RL-L@u HHffff%SL-IDIvHvHvHvL H9 0Ev%fff%@SL-L@ HHL@HDH%SL- IDwIvmHvcHvL H9 0Ev%fffff%@SL-@ )LHA[A\A^A_f 3EXHH?HH?IS70?  ? 5? ?  DF6k(defmacro if-array (array dim var condition 1st 2nd) (let ((res (gensym))) `(do ((,var 0 (1+ ,var)) (,res nil ,condition)) ((or ,res (= ,var (array-dimension ,array ,dim))) (setf ,var (1- ,var)) (if ,res ,1st ,2nd)))))94%lL-5UHWVAWAVATASMYh0AaHu vuAi(Mef$%RL-ILLS L-|VLLfS L-dVLLfS L-LILLS L-4VLLfS L-VLLfS L-VLIqffffS L-^V1IyffS L-IAATjAATMefffff$%xPL-VMfff$%xPL-tVASh 0uMff$%xPL-LVMfff$%xPL-,VAASAATAuuM ffff$%xPL-VM-fff$%xPL-VMMfff$%xPL-VAATAATM}ff$%xPL-|VMfff$%xPL-\VAASuu Mffff$%xPL-,VMfff$%xPL- VM fff$%xPL-eH%HHeH%HeH%XH(A[A\A^A_Ð5KG?DESTRUCTURE-STATE,ARRAYDIMVARCONDITION1ST2ND?%CHECK-EXTRA-ARGUMENTSL?DO?1+Ob?1-,@77@Q@KJIHGFDARGS33833DENVIRONMENT33832DWHOLE338310 7@?@?@?@ @?@? @o@?%@?%@E?IF-ARRAY-E(ARRAY DIM VAR CONDITION 1ST 2ND)F6=(defun myxor (image mask) (dotimes (i (array-dimension image 0)) (dotimes (j (array-dimension image 1)) (if (= (aref image i j) (aref mask i j)) (setf (aref image i j) 0)))))94#UL-UHVAWAVATASIL1IS L-VE1Huf%PRL-HiLHIfffffS L-|IE1Lސ%PRL-dHMLL%8QL-DVLELLfffff%8QL-$_ uH9 0Dv%f%8SL-@ tLML1%RL-L@u HHffff%SL-ILLސ%hSL-@ /L@u HHfff%SL-\ILHu%hSL-D@  0HA[A\A^A_HH?HH i (nth 2 rect)) (setf (nth 2 rect) i)) (if (< j (nth 1 rect)) (setf (nth 1 rect) j)) (if (> j (nth 3 rect)) (setf (nth 3 rect) j)) (setf (aref tmp i j) 1) (setf (aref image i j) 0) (dolist (point (look-around i j image tmp)) (let ((y (first point)) (x (second point))) (flood-fill y x rect image tmp))))95#|L-(MHl$Hl$EAWAVATASIIMD(IvH} uH9 0Lv%f%XSL-@ t"E1LHuIfS L-lDIvHvHvH} uH9 0Ov%%HSL- @ t*ILHuIffffS L-DRIvHHvH} uH9 0Lv%f%XSL-@ t*ILHuIffffS L-\DIvHvHvHvH} uH9 0Ov%ffff%HSL-@ t*ILHuIffffS L-LLEH}H%RL-LLEH}1fff%RL-tjRjRuLELL޹ IS L-LVHuȉL~DAwDIwvjRjRuuMLL޹(L-HHuHvHuȀ} t 0HA[A\A^A_.$7?%SETNTHS,ԌY0O,lLlL"L"$z$z$I$Y$p]obn.)Vr@U.r-?.A2>892DG3386670?0?00? Y .Y .Y.Y?.Y?.YTFLOOD-FILLhF6R(defun carve-into-boxes (image) (labels ((carvec (img boxes) ; (format t "carvec ") (let ((tmp (make-array (array-dimensions img) ; :element-type 'bit :initial-element 0)) (rct (append '(0 0) (array-dimensions img)))) (if-array img 0 i (= 1 (aref img i 0)) (progn ; (write-plain-pbm "a1.pnm" img) (flood-fill i 0 rct img tmp) ; (write-plain-pbm "a11.pnm" img) ; (write-plain-pbm "a12.pnm" tmp) (if-array tmp 1 j (blank-column-p tmp rct j 1) (progn (setf (fourth rct) j) ; (format t "r: ~A~%" rct) ; (write-plain-pbm "a2.pnm" img) ; (format t "t: ~A~%" (trim-box rct tmp)) (let ((i4 (copy-rect (trim-box rct tmp) tmp))) ; (write-plain-pbm "aa.pnm" img) ; (write-plain-pbm "a.pnm" i4) ; (write-plain-pbm "aaa.pnm" tmp) (push i4 boxes) ; (read) ) (let ((nim (xtrim img tmp))) (if nim (carvec nim boxes) (reverse boxes)))) (reverse (push tmp boxes)))) (if (< 1 (array-dimension img 1)) (progn (setf (second rct) 1) (carvec (copy-rect rct img) boxes)) (reverse boxes)))))) (let ((i5 (copy-image image))) ; (write-plain-pbm "a0.pnm" i5) (carvec i5 nil))))96# L-uEUHVIafffS L-VH 0IiMIAffffzo_L-aUHVAWAVATASILIffS L-IjRjRhAWh 0h 0jh.0h 0A 0 0 0PIffffS L-tVLIffffS L-TII ffS L-4VL]E1h 0L@u HHfff%SL-IML1fffff%8QL-H@uH 0Dv%Hff%8SL-HuMHu@ uGL1IfffS L-tL uH9 0Dv%%8SL-L@  L@u HHfff%SL-I} jRjRAVjLELL޹(IffS L-E1h 0jL@u HHfff%SL-VjRjRASLELH I!fffS L-tHuL}HHu@ uJLHIfS L-MJ: J9 /2 $::v1::P:u:}TrI /Tw1T]$4P\/ P?NIM?I4DG33879DG33876DG33875DG33872?RCTDDIMSAz0?:??]?,'c?jj j? j?? j j"6V96,?CARVECCARVE-INTO-BOXES,K"Kx-K?I50?-K?KVWF6X(defun boxify (image &key (tol 1) preserve-spaces (rect (append '(0 0) (array-dimensions image)))) (let ((boxes (mapcar #'(lambda (r) (copy-rect r image)) (cut-into-boxes rect image tol)))) (if preserve-spaces boxes (remove-if #'(lambda (a) (or (zerop (array-dimension a 0)) (zerop (array-dimension a 1)))) boxes))))97HX#^LL-H~HlHlEUHE1HMEff$% QL-AWAVATAS} u HHu} uEHuIfffffS L-tIIffS L-THuп 0 0eH,%X eH%XfD)8fD)xeo<%H8HheH%HH@HxHpHIAWHH3eH)%eH%eH;%wHCe$%HH-$FFLHFF %hQFM H}LVH~#HH~+HILEH}HuIfffffS L-LID؃McLL؃LOLDK AL-H 0eH,% eH%eH;%we$%H{HsHLff%pPL-HL~M[A [HuHvHeH%HHeH%HeH%XI} t LA[A\A^A_ILA[A\A^A_I!c ffffTOL?PRESERVE-SPACESRECTy, L-u!UHWVHHuI9c ,)!00?)?)"6X97h",BOXIFYC@L-UHVH1IfffS L-H@uH 0Dv%1%8SL-@ uLH}HIS L-|H@uH 0Dv%1%8SL-TÐ,Ub7Tb>S\67 50?"6X97V,[R,mWVULk@hHNkOgADG33888DG33890DG33889DG33887DG338867?PRESERVE-SPACES80 S i?? ?e?e?TX[F6(defun cut-into-words (image &key (tol 1) (rect (append '(0 0) (array-dimensions image)))) (labels ((space-p (box) (or (zerop (- (third box) (first box))) (zerop (- (fourth box) (second box))))) (wordec (boxes word words) (if (null boxes) (nreverse (if word (push word words) words)) (if (space-p (car boxes)) (wordec (cdr boxes) nil (if word (push word words) words)) (wordec (cdr boxes) (push (car boxes) word) words))))) (mapcar #'(lambda (w) (loop for b in w minimize (first b) into mini maximize (third b) into maxi minimize (second b) into minj maximize (fourth b) into maxj finally (return (list mini minj maxi maxj)))) (wordec (cut-into-boxes rect image tol) nil nil))))97#MLL-2H~HlHlEUHE1HMEff$% QL-AWAVATAS} u HHu} uEHuIifffffS L-tIqIyffS L-THu 0 0eH,%X eH%XfD)8fD)xeo<%H8HheH%HH@HxHpHIAWMLEH}HuIffffS L-I 0 0IffffL-ID؃McLL؃LOLDK AL-\H 0eH,% eH%eH;%we$%H{HsHLff%pPL- HL~M[A [HuHveH%HHeH%HeH%XHA[A\A^A_dfffYZy, dL-UHVAWAVATASA 0LuE1E1h 0jjh 0jjh 0jjh 0D]A M~MvDDM_} t3LL uH9 0Lv%f%XSL-L@ t .0HuMDIwHvHvHu} t3H}Huȉ uH9 0Ov%%HSL-@ t.0HuHuHuDIw}HvHu} t8H}Hu uH9 0Lv%fff%XSL-T@ t.0HuHuHuDIwHv HvHvHu} t8H}Hu uH9 0Ov%%HSL-@ .0HuHuHuATuuu Mff$%xPL-tHPA[A\A^A_þ 0HPA[A\A^A_MnK^fff,dd KpyU^n1:DLOOP-MAXMIN-FLAG-33914DLOOP-MAXMIN-TEMP-33913MAXJDLOOP-MAXMIN-FLAG-33912DLOOP-MAXMIN-TEMP-33911MINJDLOOP-MAXMIN-FLAG-33910DLOOP-MAXMIN-TEMP-33909MAXIDLOOP-MAXMIN-FLAG-33908DLOOP-MAXMIN-TEMP-33907MINIDLOOP-LIST-339060?M?H?F?D???=?;?6? 4? 2 - *'#?"6\98,CUT-INTO-WORDS@7L-qUHAWAVATIIMA uXA t9eH,% eH%eH;%we$%LsL{HILA\A^A_Ic DIt$IfL-T@ tcDIt$VA t9eH,% eH%eH;%we$%LsL{HIL 0AXDuyIt$VDupI|$eH,% eH%eH;%we$%H{LsHIHLAXff&fff2WL-UHAWIDyIwoHveHvVDYIw_ uHH)H@fffff% SL-lH@uH 0Dv%1%8SL-D@ DHIw>Hv4Hv*HvVDIwHv_ uHH)Hffff% SL-H@uH 0Dv%1%8SL-tA_A_Ð,>QHH?HH,=f= 7k9aAGkH`DG33904DG33915DG33905DG33903DG33902780 w _= =?==?=?e=?T=\aF6w(defun observe-word (freqs tree image) (apply #'shortest-chain freqs (apply #'append (mapcar #'(lambda (i0) (let ((c0 (char-chains-p tree i0))) ; (format t "~%c0 ~a~%" c0) (if (and c0 (zerop (second (caaar c0)))) (list c0) (mapcar #'(lambda (i1) (let ((c1 (char-chains-p tree i1))) ; (format t "~%c1 ~a~%" c1) (if (and c1 (zerop (second (caaar c1)))) c1 (guess-char-chains tree i1)))) (carve-into-boxes i0))))) (boxify image)))))98_#RL-YUHAPWVAWAVATASjRjRu 0 0eH,%X eH%XfD)8fD)xeo<%H8HheH%HH@HxHpHIAWHH3eH)%eH%eH;%wHCe$%HH-$FFLHFF %hQFMH}LVH~#HH~+HIHuIS L-ID؃>McLL؃LO%LDK AL-H 0eH,% eH%eH;%we$%H{HsHLff%pPL-LHL~M[A [HuHvHeH%HHeH%HeH%X1Mf$%xQL-IfffffS L-M=ffff$%xQL-L]LeLuL}I$%Qff$BfffiL-UHWVAWAVATASH}HuIAS L-V} HuȉHvHvHvHvH~@uH 0Dv%1ff%8SL-4@ tKH}Ⱦ 0eH,% eH%eH;%we$%H{HsHHA[A\A^A_ÿ 0 0eH,%X eH%XfD)8fD)xeo<%H8HheH%HH@HxHpHIAWHH3eH)%eH%eH;%wHCe$%HH-$FFLHFF %hQFMIH}LVH~#HH~+HIHuIQfS L-ID؃McLL؃LOLDK AL-H 0eH,% eH%eH;%we$%H{HsHLff%pPL-THL~M[A [HuHveH%HHeH%HeH%XHA[A\A^A_K]o:fff&L-UHWVAWH}HuI)ffffS L-IA DIwHvHvHvu}H~@uH 0Dv%1%8SL-<@ tLA_H}HuA_I1c fI\nfff,?d땰?hIpIwIC1k0???"6d98OBSERVE-WORDCW,k=Xji=\GdGk~Gs}DG33936DG33938DG33937DG33935DG33934?C0I0k0 / ?rp? =??"6d98|lfC[N., b)'$N'fDG33932DG33941DG33933DG33931DG33930k&0 7 ?|z? b? b? bdgF"6(defparameter english-alphabet "abcdefghijklmnopqrstuvwxyz")98@<'?ENGLISH-ALPHABETEabcdefghijklmnopqrstuvwxyzF"6(defparameter latin-alphabet "abcdefghijlmnopqrstuvxy")987'?LATIN-ALPHABETEabcdefghijlmnopqrstuvxyF"6(defparameter welsh-alphabet "abcdefghijlmnoprstuwyâôŵŷî")98?'?WELSH-ALPHABETabcdefghijlmnoprstuwyâôŵŷîF"6(defparameter russian-alphabet "абвгдежзийклмнопрстуфхцчшщьъэюя")99 `'?RUSSIAN-ALPHABETабвгдежзийклмнопрстуфхцчшщьъэюяF"6(defparameter ukrainian-alphabet "абвгґдеєжзиiїйклмнопрстуфхцчшщьюя")99#e'?UKRAINIAN-ALPHABETабвгґдеєжзиiїйклмнопрстуфхцчшщьюяF"6t(defparameter persian-alphabet "ﺎآاﺍﺐﺒﺑﺏﭗﭙپﺖﺘﺗﺕﺚﺜﺛﺙﺞﺠﺟﺝﭻﭽﭼﭺﺢﺤﺣﺡﺦﺨﺧﺥﺪﺩﺬﺫﺮﺭﺰﺯﮋژﺲﺴﺳﺱﺶﺸﺷﺵﺺﺼﺻﺹﺾﻀﺿﺽﻂﻄﻃﻁﻆﻈﻇﻅﻊﻌﻋﻉﻎﻐﻏﻍﻒﻔﻓﻑﻖﻘﻗﻕﮏﮑﮐکﮓﮕﮔگﻞﻠﻟﻝﻢﻤﻣﻡﻦﻨﻧﻥﻮوﻪﻬﻫﻩﯽﻴﻳﻯ")99=At'?PERSIAN-ALPHABET_ﺎآاﺍﺐﺒﺑﺏﭗﭙپﺖﺘﺗﺕﺚﺜﺛﺙﺞﺠﺟﺝﭻﭽﭼﭺﺢﺤﺣﺡﺦﺨﺧﺥﺪﺩﺬﺫﺮﺭﺰﺯﮋژﺲﺴﺳﺱﺶﺸﺷﺵﺺﺼﺻﺹﺾﻀﺿﺽﻂﻄﻃﻁﻆﻈﻇﻅﻊﻌﻋﻉﻎﻐﻏﻍﻒﻔﻓﻑﻖﻘﻗﻕﮏﮑﮐکﮓﮕﮔگﻞﻠﻟﻝﻢﻤﻣﻡﻦﻨﻧﻥﻮوﻪﻬﻫﻩﯽﻴﻳﻯF"6(defparameter persian-corpus " ﻰﺳﺭﺎﻓ ")991'?PERSIAN-CORPUS ﻰﺳﺭﺎﻓ F6O(defun calculate-frequencies (charset coprus-stream) (labels ((get-char (stream) (let ((c (read-char stream nil nil))) (if (null c) 'eof (if (position c " *\"'.,?!:;()-/") #\Space (if (position (char-downcase c) charset :test #'char=) (char-downcase c))))))) (do ((hash (make-hash-table :test #'equal)) (max-freq 0) (c1 #\Space c2) (c2 (get-char coprus-stream) (get-char coprus-stream))) ((eq c2 'eof) (maphash #'(lambda (k v) (setf (gethash k hash) (/ (- max-freq v) max-freq 1.0))) hash) hash) (if (and c1 c2 (not (char= #\Space c1 c2))) (setf max-freq (max max-freq (incf (gethash (coerce (vector c1 c2) 'string) hash 0))))))))99#L-UHWVAWAVATASIqH^ ؃HIyIfffS L-VjHuVeH)%eH%eH;%wHCe$%HHwH} VH}HuIfffL-4IL]BA A AMIAMIIuM9 0Dv% 0@ H]H[SASATHHeH)%eH%eH;%wHCe$%I߸ADH}AWHuuFLkI0u/HuHvHHHHHHH 0Dv%IH 0Dv%H@ tLLIfffS L-IL}ML1IffS L-@u HH%SL-VjRjRAVM1Hu IfS L-lHIH}L uH9 0Ov%fff%HSL-4@ tHuLHLE1% RL- MH}HuIL-IMM;HHCeH)%eH%eH;%wHCe$%HH-$FFLHFF %hQFMH}LELVH~#LF+HH~3HHHuȹIfffS L-,HuHA[A\A^A_ff%ͦHH?HHalist (hash) (loop for k being the hash-keys of hash using (hash-value v) collect (cons k v)))9:[s#]L-UHVAWAVATASh 0A 0uA 0uHuIffffS L-VHHưfffff%PL-VH}Hưffff%RL-lVujuuLEH}HuIfS L-ALISTF6(defun alist->hash (alist &key (test #'equal)) (let ((hash (make-hash-table :test test))) (dolist (p alist hash) (setf (gethash (car p) hash) (cdr p)))))9:z#)LL-H~HlHlEUHE1HMEff$% QL-AWAVATASMI} u IQH^ ؃HHuIYHuIafS L-\IL]KD؃uiM{DubIwVDuZIwLAXLfS L- M[A uLA[A\A^A_fhͦfff]*\]), 1 `wa}%,DG34047n??ALIST0  ? ?[ tALIST->HASHF6(defun file->freqs (name) (alist->hash (with-open-file (f name) (read f))))9:@K#.L-MUHVh 0h 0MM=$%Tfff=L-} t2} 0Dv%IiLEIqfffS L-fffL-tHuIyffffS L-THuVIfffS L-4HV.0Hu^HM$%@PL-eH%HeH%0HKHHPHHSeH%0yHxeH4%?s HHIc u,XJH'I@HDG34054DG34053m0??H?H?Xv?FILE->FREQSF6>(defun freqs->file (name freqs) (with-open-file (f name :direction :output :if-exists :supersede :if-does-not-exist :create) (format f "~s" (sort (hash->alist freqs) #'< :key #'cdr))))9:#hL- UHWVAWh 0h 0MM=$%Tf=L-} t2} 0Dv%I9LEIAfffS L-fffL-tjRjRuAIAQAYMaIiIq8IyS L-,HuVVjRjRHuIfffS L-VIH^ ؃ HVIH^ ؃HIAX IfffffS L-VL}A toAWH}uGHkVH0u/HuHvHHHHHHH 0Dv%HuHH 0Dv%H@ t@M ARMIHuI4%/c ffff L-9I.0tL 0H}IS L- 0VHMe$%xRL-M}ff$%RL-|.0Hu1M$%@RL-\HM$%8PL-FILEF6|(defun split-script (script charset0 charset1 &key (script0 (make-pathname :type "0" :defaults script)) (script1 (make-pathname :type "1" :defaults script))) (let (lst0 lst1) (dolist (c (with-open-file (f script) (read f))) (let ((p (position (car c) charset0))) (if (null p) (push c lst0) (push (list (char charset1 p) (cadr c)) lst1)))) (with-open-file (f script0 :direction :output :if-exists :supersede :if-does-not-exist :create) (format f "~s" lst0)) (with-open-file (f script1 :direction :output :if-exists :supersede :if-does-not-exist :create) (format f "~s" lst1))))9:|#!LL-H~HlHlEUHE1HMEf$% QL-AWAVATAS} u>jRjRAAMIIQHu IYfffffS L-lHu} u:jRjRAAMaIQHu IYffS L-,HuA 0h 0h 0h 0MUM $%Tfffff L-} t2} 0Dv%IiLEIqfffS L-fffUL-HuIyffffS L-HuILIS L-dV.0Hu^HM$%@PfffL-4eH%HeH%0HKHHPHHSeH%0yHxeH4%?s HHVAHuL~DMgLujRjRATM 0 0 IS L-IA u9eH,% eH%eH;%we$%L{L[IH}LIS L-,VDAIw7vM $%xPL-HHueH,% eH%eH;%we$%H{HsHHuHuHvHu} Hh 0h 0MM$%TfffL-d} t2} 0Dv%IiLEIqfffS L-,fffL-jRjRuAAAMII8IyS L-HuVIASA tcMDuAD$LkI0u,It$HHHHHHH 0Dv%IH 0Dv%@ t/MIHPIffffS L-4;I.0tL 0HPIffffS L- 0HHV.0Hu^HM5$%@P5L-eH%HeH%0HKHHPHHSeH%0yHxeH4%?s HHh 0h 0MM$%TfL-L} t2} 0Dv%IiLEIqfffS L-fffL-jRjRuAAAMII8IyS L-HuVIuA tcMDuAD$LkI0u,It$HHHHHHH 0Dv%IH 0Dv%@ t>MARMIHPI4%/c L- AI.0tL 0HPIffffS L- 0VHMM$%xRL-Meff$%RL-.0Hu1M$%@RL-tHM$%8PL-TeH<%HeH%0HWHHXHH_eH%0yHxeH4%?s L]LeLuL}$%Pf"4?SCRIPT0?SCRIPT1TYPEE0DEFAULTSMAKE-PATHNAMEE1kjE~srE~s,{zI7eyosm1 mz4SywS*xSJwPqhpVg}7Dw}.6ZKuel`cDG34081DG34080DG34079DG34078DG34077DG34076DG34075DG34074DG34071DG34070*DG34065DG34069DG34068?LST1?LST0?SCRIPT1?SCRIPT0?CHARSET1?CHARSET0?SCRIPT0m X?*O7L7?(I7??T ??*6 4 ?(1?w?rwSKw Gw4S?m??? ? ??T?T?Tx?SPLIT-SCRIPT9F"6(defparameter latin->cyrillic "ABCEHIJKMOPTXabceijmnouy")9;9'?LATIN->CYRILLICEABCEHIJKMOPTXabceijmnouyF"6(defparameter cyrillic->latin "АВСЕНIJКМОРТХаЬсеijтпоиУ")9;M'?CYRILLIC->LATINАВСЕНIJКМОРТХаЬсеijтпоиУF6(defun bilinear (f x y x1 y1 x2 y2) (let ((dy21 (- y2 y1)) (dx21 (- x2 x1)) (dy2 (- y2 y)) (dy1 (- y y1)) (dx2 (- x2 x)) (dx1 (- x x1))) ; (format t "~a ~a ~a ~a ~a ~a ~a ~a ~a ~a " (funcall f x1 y1) (funcall f x2 y1) (funcall f x1 y2) (funcall f x2 y2) dx21 dy21 dx1 dx2 dy1 dy2) (cond ((and (= x x1 x2) (= y y1 y2)) (funcall f x1 y1)) ((= x x1 x2) (+ (* (/ (funcall f x1 y1) dy21) dy2) (* (/ (funcall f x1 y2) dy21) dy1))) ((= y y1 y2) (+ (* (/ (funcall f x1 y1) dx21) dx2) (* (/ (funcall f x2 y1) dx21) dx1))) (t (+ (* (/ (funcall f x1 y1) dx21 dy21) dx2 dy2) (* (/ (funcall f x2 y1) dx21 dy21) dx1 dy2) (* (/ (funcall f x1 y2) dx21 dy21) dx2 dy1) (* (/ (funcall f x2 y2) dx21 dy21) dx1 dy1))))))9;#kffL-8Hl$(Hl$(EVAWAVATASIMLeL}H}L uHH)H% SL-VLL uHH)H% SL-lVH}Hu uHH)Hfffff% SL-4VH}L uHH)H % SL-VLHu uHH)H9% SL-VH}L uHH)He% SL-VLELL޹I) fffffS L-|@ t]LELHuعI) S L-T@ t5LLLH0A[A\A^A_ɉ؃LO2LDK ALELL޹I) fffS L-@ LLL؃LOLDK fffffAL-HHuff%0SL-HHuff%(SL-VLHuL؃LOLDK fffffAL-LHHuff%0SL-4HHuff%(SL-_ u H.fff%SL-H0A[A\A^A_LELHuعI) S L-@ LLL؃LOLDK fffffAL-HHuff%0SL-lHHuff%(SL-TVLLL؃LOLDK AL-$HHuff%0SL- HHuff%(SL-_ u Hrfff%SL-H0A[A\A^A_LLL؃LOLDK ffAL-IH}HuI1 fffffS L-dVH}Hu%(SL-L_%(SL-T#9E|EdDMWD%%w%D890DG34097DG34095J0hRMAXT0p p???j0?h0?e0?0?0? 0?%0?%0~Ereturn polar transform of cartesian IMAGE with N divisions along theta axisF6(defun logpolar (image) "return the log-polar transform of cartesian IMAGE" (let* ((lmage (make-array (array-dimensions image))) (h (array-dimension image 0)) (w (array-dimension image 1)) (dt (/ (* 2 pi) w)) (b (exp (/ (log h) h)))) (dotimes (i h lmage) (dotimes (j w) (let* ((r (expt b i)) (th (* j dt)) (x (round (+ (* r (cos th)) (/ w 2)))) (y (round (+ (* r (sin th)) (/ h 2))))) (if (and (< 0 x w) (< 0 y h)) (setf (aref lmage i j) (aref image y x))))))))9=(#fYL- UHVAWAVATASHuIfffS L-HǰIffS L-VH}1IffS L-VH}HIffffS L-\IILfff%0SL-j# t L-(H~HlHlEUHt rtAPWV(s (h 0u1 09ȉLw% VuAWAVATASL]} u1Hu} u1Hu} u"L1I9ffS L-DHu} u*LHI9ffffS L-HuLeujLHu uH9 0Mv%fffff%PSL-@ .HuVL}uE1LHx uH9 0Mv%%PSL-@ uzMLLff%8QL-lL u Hff%SL-DIL@u HGHff%SL-IQLH 0H_ u H\ff%SL-HuL@u HHf%SL-IHuH 0HHVL޹IAfffffS L-d_A[A\A^A_$%0SHH?HHA]#2*t L-Z0YH~HlHlEUHt rtAPWV0s 0h 0u1 09ȉLw%(VuAWAVATASL]} u1Hu} u1Hu} u"L1IIffS L-DHu؀} u*LHIIffffS L-HuЀ} u2jRjRASuLEH}Huй(IQffS L-HuLeujLHu uH9 0Mv%fffff%PSL-@ HxVL}uE1LHh uH9 0Mv%fff%PSL-L@ MLLfffff%8QL-$HHu uHH)Hz% SL-HHIYS L-L u Hff%SL-IL@u HHff%SL-|ILH 0H_ u Hff%SL-H`VMuE1LHP uH9 0Mv%ffff%PSL-@ vLHu uHH)H fffff% SL-DVLLމ uHH)H2% SL-_LEfff%8QL-HHu؉ uHH)HF% SL-VLELLfffff%8QL-HHx uHH)HOffff% SL-t_%(SL-dL u Hpff%SL-x&w5Yv5W\l4)R,I@H7?\4V?;S'& #5t5Wp|O`DLOOP-SUM-34156DLOOP-LIMIT-34155DLOOP-SUM-34154DLOOP-LIMIT-34153?IMAGE-DV?IMAGE-AVBhMASK-DVMASK-AV?JC?ICM0 G ?*DA?&?$?"1? 1 1?1?1?51? 1?1?v1?v1?v1?v1CROSS-CORRELATION9DF6S(defun image-cross-correlation (mask image) (let* ((mask-av (image-mean mask)) (mask-dv (image-deviation mask mask-av)) (lmage (make-array (array-dimensions image))) (i0 (+ 0 (floor (array-dimension mask 0) 2))) (i1 (1+ (- (array-dimension image 0) (floor (array-dimension mask 0) 2)))) (j0 (+ 0 (floor (array-dimension mask 1) 2))) (j1 (1+ (- (array-dimension image 1) (floor (array-dimension mask 1) 2))))) (loop for i from i0 below i1 do (loop for j from j0 below j1 do (setf (aref lmage i j) (cross-correlation mask image i j mask-av mask-dv)))) lmage))9?S#{L-UHAWAVATASIILIS L-VLHuعIfS L-VL޹IffffS L-HǰIffS L-dVL1IfffS L-DHHIS L-$@u H1ffff%SL-VL1IfffS L-VL1IfffS L-HHIS L-_ uHH)Hfffff% SL-l@u HH%SL-DVLHIfffffS L-HHIS L-@u H1ffff%SL-VLHIfffffS L-VLHIfffffS L-HHIS L-d_ uHH)Hxfffff% SL-4@u HH%SL- VLuuLHu uH9 0Mv%fff%PSL-@ fL}uLHu uH9 0Mv%ff%PSL-@ jRjRATASAVMH}Huй0IffS L-\LMH]ȉ؃-{#H{H{ A@L;C#HC+H9HIH<LC fff% RL-L@u HHffff%SL-IHL@u HHf%SL-lI`HHuH8A[A\A^A_ffHH?HHVDG34211DG342090> >@?= %FOURIER-MAGNITUDES!F6l(defun image-max (image) (let ((y 0) (x 0) (m (aref image 0 0))) (dotimes (i (array-dimension image 0) (values y x m)) (dotimes (j (array-dimension image 1)) (if (> (aref image i j) m) (setf m (aref image i j) y i x j))))))9B@#ZL-UHAWAVATASIjjM11fff%8QL-VL1IfffS L-VE1Huf%PRL-HYLHIfffffS L-\IE1Lސ%PRL-DHMLL%8QL-$HHuȉ uH9 0Ov%fff%HSL-@ t&MLLff%8QL-HuLuL}L@u HHf%SL-ILLސ%hSL-@ ?L@u HHfff%SL-LILHu%hSL-4@ uuuȹL]LeLuL}$%PfHH?HH (aref image 0 j) m) (setf m (aref image 0 j) x j)))))9B|@#;L-UUHAWAVATASIjM11ffff%8QL-ILHIfffS L-IE1Lސ%PRL-HM1L%8QL-dHL uH9 0Ov%fff%HSL-4@ t!M1Lfff%8QL-IL}L@uHpgHff%SL-ILLސ%hSL-@ GjuATL]LeLuL}$%PHH?HHaes{DG34223R80ja ga ?a?!aa)?ROT-MAXF6i(defun fourier-correlation (mask image) (fourier-magnitudes (inverse-fft-2d! (phase-difference (fft-2d! (duplicate-image image)) ; почему тут наооборот?! (fft-2d! (duplicate-image mask))))))9B#L-UHWVIS L-IfS L-VHuIfffS L-IfS L-_IS L-lIfS L-TIc fff~FFT-2D!INVERSE-FFT-2D!$,*BXE|EdDp,yM0??*?FOURIER-CORRELATIONF6(declaim (notinline fourier-correlation!))9B*L-u"UHI9IAc ff,NOTINLINEFOURIER-CORRELATION!,-F6(defun fourier-correlation! (f1 f2) "maps into ft1" (fourier-magnitudes! (inverse-fft-2d! (phase-difference! f2 f1))))9B@z#L-uUUHWVHHuIqfffS L-IyfS L-Ic fff!,&,\8yLMx4^wF2F10?\?\0/Emaps into ft1F6(declaim (notinline fft-n-mags!))9C@!L-u"UHI9IAc ff,.FFT-N-MAGS!,3F6(defun fft-n-mags! (image) (let ((f (real-fft-2d! image))) (values (fourier-magnitudes f) f)))9Cd#L-uMUHVIifffS L-VIqS L-Vu$%PfffREAL-FFT-2D!$,Tc-TAb-DI_0?-T?T54F6x(defun for-mellin (image) ; (format t "4mellin~%") (multiple-value-bind (m f) (fft-n-mags! image) ; (format t "info-mellin~%") (values (logpolar (grayscale-image! (high-pass! (fourier->image m) ) )) f)))9C9@#L-UHVM=ARHuI4%/c =L-)sHcH) h 0uHuIS L-IfS L-lIfS L-TI fS L-IMAGEHIGH-PASS!GRAYSCALE-IMAGE!,6bԉbĖbbb|DQdR0?b?b?7FOR-MELLINF6h(defun logarithm-filter (image &optional (scale 0.0001)) (let ((lmage (make-array (array-dimensions image))) (c (/ 255 (log (1+ (* scale (nth-value 2 (image-max image)))))))) (dotimes (i (array-dimension image 0) lmage) (dotimes (j (array-dimension image 1)) (setf (aref lmage i j) (round (* c (log (1+ (* scale (aref image i j)))))))))))9Cwh#:0HL-UHrtWVs h 0uɸ 0E@%PAWAVATASLe} u IyHuLIffffS L-|HǰIffS L-\VHVMARLI4%/c fL-$H H+ 0~Ht H`H}fffff%(SL-@u HH%SL-IfS L-Hff%0SL-VL1IfffS L-|VE1Huf%PRL-dHLHIfffffS L-4IE1Lސ%PRL-HyMLL%8QL-H}ffff%(SL-@u H H%SL-IfS L-H}ffff%(SL-IfS L-tLMH]؃{H{H{A@L;C#HC+H9HIH<LC fff% RL-L@u HHffff%SL-ILLސ%hSL-@ L@u HHfff%SL-lILHu%hSL-T@ HuHA[A\A^A_ÐHH?HHimage (image) (let* ((lmage (make-array (array-dimensions image))) ; (m image) ;(fourier-magnitudes image)) ; (c (/ 255 (max 1 (log (1+ (* 0.0001 (nth-value 2 (image-max m)))))))) (n (array-dimension image 0))) (dotimes (i n lmage) (dotimes (j n) (setf (aref lmage (if (> (/ n 2) i) (+ (/ n 2) i) (- i (/ n 2))) (if (> (/ n 2) j) (+ (/ n 2) j) (- j (/ n 2)))) ; (round (* c (log (1+ (* 0.0001 (aref m i j))))))))))) (aref image i j))))))9CA#QKL-UHVAWAVATASHuIQfffS L-HǰIYffS L-VH}1IaffS L-IAWE1Huffff%PRL-dH9ME1L%PRL-DHLHfffff%0SL-HL uH9 0Ov%fff%HSL-@ tDLHf%0SL-HL u H^%SL-NLHffff%0SL-L uHH)Hfff% SL-TVLHfffff%0SL-4HL uH9 0Ov%fff%HSL-@ tDLHf%0SL-HL u H}^%SL-NLHffff%0SL-L uHH)Hfff% SL-lVLELLfffff%8QL-L_AXH]Љ؃{H{H{A@}L;C#{HC+H9vHIH<LC fffff% RL-L@u HBHffff%SL-ILLސ%hSL-|@ 7L@u HLHfff%SL-DILHu%hSL-,@ HuHA[A\A^A_ÐHH?HH8F6D(defun fourier-for-rotation (image) (let ((lmage (make-array (array-dimensions image))) (n (array-dimension image 0))) (dotimes (i n lmage) (dotimes (j n) (setf (aref lmage (if (> (/ n 2) i) (+ (/ n 2) i) (- i (/ n 2))) (if (> (/ n 2) j) (+ (/ n 2) j) (- j (/ n 2)))) (aref image i j))))))9DMD#QKL-UHVAWAVATASHuIQfffS L-HǰIYffS L-VH}1IaffS L-IAWE1Huffff%PRL-dH9ME1L%PRL-DHLHfffff%0SL-HL uH9 0Ov%fff%HSL-@ tDLHf%0SL-HL u H^%SL-NLHffff%0SL-L uHH)Hfff% SL-TVLHfffff%0SL-4HL uH9 0Ov%fff%HSL-@ tDLHf%0SL-HL u H}^%SL-NLHffff%0SL-L uHH)Hfff% SL-lVLELLfffff%8QL-L_AXH]Љ؃{H{H{A@}L;C#{HC+H9vHIH<LC fffff% RL-L@u HBHffff%SL-ILLސ%hSL-|@ 7L@u HLHfff%SL-DILHu%hSL-,@ HuHA[A\A^A_ÐHH?HH d (sqrt (+ (expt (- i n/2) 2) (expt (- j n/2) 2)))) 0 (aref image i j)))))))9E,A{#LDHL-UHrtWVs h 0uɸ 0E@%PAWAVATASM} u;H}1I!ffS L-HH@%0SL-lHuHuI)fS L-LHǰI1ffS L-,VH}1I!ffS L- HH%0SL-IH}1I!S L-VE1Huf%PRL-HH}HI!ffffS L-VE1Huf%PRL-tHLLމ uHH)Hf% SL- d (sqrt (+ (expt (- i n/2) 2) (expt (- j n/2) 2)))) 0 (aref image i j)))))))9EM#/)HL-NMUHrtWVs h 0uɸ 0E@%PAWAVATASMALe} u7L1IIS L-HH@%0SL-lHuL1IIS L-LHH%0SL-4VL1IIfffS L-VE1Huf%PRL-H9LHIIfffffS L-VE1Huf%PRL-HLHu uHH)H% SL-|HHLfffS L-\VLHu uHH)H% SL-,HHLfffS L- _ u Hfff%SL-IQfS L-H} uH9 0Ov%fffff%HSL-@ t1MLLfffff%8QL-tLML%RL-\L@u HHffff%SL-,ILHu%hSL-@ _HL@u HH%SL-ILHu%hSL-@ LHA[A\A^A_fHH?HH<#.L-MUHWVM]ARHuIiffS L-Iq4%/c fffff]L-)sHcH) h 0uMARHuIifffffS L-TIq4%/c fffffL-,)sHcH) h 0uHuIyS L-VHuعIyfffS L-_IS L-Vuuй$%Pf~;6/,W1;Wv:W9D* ,) dNq<Zp12M0? W?W?W?W?W?WHFOURIER-MELLIN-CORRELATIONF6M(defun pre-fft (n &key (complex-exp-vector nil)) (declare (optimize (speed 3) (safety 0))) (declare (type fixnum n)) (let* ((the-vector (if complex-exp-vector complex-exp-vector (make-array n))) (s (/ (* 2 pi) n)) (c1 (complex (cos s) (- (sin s)))) (c2 (complex 1.0d0 0.0d0))) (declare (type (simple-array complex (*)) the-vector)) (dotimes (i n the-vector) (setf (aref the-vector i) c2 c2 (* c2 c1)))))9F#ƽ=LL-H~HlHlEUHE1HMEff$% QL-AWAVATAS} tLeH}Hưff%RL-IHuHHH*A^)eH)%eH%eH;%wHCe$%HFVIfffffS L-VHuIfffS L-f%SL-_IS L-III IS L-IE17MLL% RL-tLLfff%(SL-\IIHuI9|LHA[A\A^A_fff-DT!@?COMPLEX-EXP-VECTOR./COMPLEX?,To{t,`qe?THE-VECTOR?COMPLEX-EXP-VECTORT0ro G? ?T?TJPRE-FFTF6v(defun fft! (complex-vector) (let* ((n (length complex-vector)) (exponent (round (log n 2))) (W (pre-fft n)) (MM 1) (LL n) NN JJ c1 c2) (declare (optimize (speed 3) (safety 0))) (dotimes (k exponent) (setf NN (/ LL 2) JJ MM) (do* ((i 0 (+ i LL)) (kk NN (+ i NN))) ((>= i N)) (setf c1 (+ (aref complex-vector i) (aref complex-vector kk)) (aref complex-vector kk) (- (aref complex-vector i) (aref complex-vector kk)) (aref complex-vector i) c1)) (cond ((> NN 1) (do ((j 1 (1+ j))) ((>= j NN)) (setf c2 (svref W JJ)) (do* ((i j (+ i LL)) (kk (+ j NN) (+ i NN))) ((>= i N)) (setf c1 (+ (aref complex-vector i) (aref complex-vector kk)) (aref complex-vector kk) (* (- (aref complex-vector i) (aref complex-vector kk)) c2) (aref complex-vector i) c1)) (incf jj MM)) (setf LL NN) (setf MM (* MM 2))))) (let ((j 0) (nv2 (/ n 2)) k) (dotimes (i (1- N)) (if (< i j) (setf c1 (aref complex-vector j) (aref complex-vector j) (aref complex-vector i) (aref complex-vector i) c1)) (setf k nv2) (loop (if (> k j) (return)) (decf j k) (setf k (/ k 2))) (incf j k))) complex-vector))9G#C=L-UHAWAVATASILfff%pSL-VHHI fffffS L-I fS L-VHuعI fffS L-lVjuh 0h 0A 0h 0ujHuffff%PRL-4HH}Hffff%0SL- HuHuHuE1LeKLLfff%SL-VLLff%SL-_ u Hfff%SL-ILL%SL-VLLff%SL-l_ uHH)Hfffff% SL-F'!) g8g} g| gp%< $s5\U^DG34325?NV2KKNDG34317qe?JJ?NN ?EXPONENTTCOMPLEX-VECTOR0?/?- ? ?R ??? ????? ? u?5MFFT!F6>(defun inverse-fft! (complex-vector) (let ((n (length complex-vector))) (dotimes (i N) (setf (aref complex-vector i) (conjugate (aref complex-vector i)))) (fft! complex-vector) (dotimes (i N complex-vector) (setf (aref complex-vector i) (/ (conjugate (aref complex-vector i)) N)))))9H>#YL-UHAWAVATASMILfff%pSL-VIE1L%PRL-HLLff%SL-LffffS L-tLMfff%SL-\L@u HJHffff%SL-,ILL%hSL-@ gLIfffS L-LeE1L%PRL-HLLff%SL-LffffS L-HHuff%0SL-LMfff%SL-lL@u HHffff%SL-<=$/<TDG34404DG34402DG34400DG34398DG34396DG34394TX0    ?   ??? ? e?= \,F6 (defun %rotate-image (image a) (declare (optimize (speed 3) (safety 0))) (let* ((lmage (make-array (array-dimensions image))) (h (array-dimension image 0)) (w (array-dimension image 1)) (c (cos (- a))) (s (sin (- a))) (i0 (/ h 2)) (j0 (/ w 2))) (dotimes (i2 h lmage) (dotimes (j2 w) (let ((i1 (+ i0 (* s (- j2 j0)) (* c (- i2 i0)))) (j1 (+ j0 (* c (- j2 j0)) (* (- s) (- i2 i0))))) (setf (aref lmage i2 j2) (round (bilinear #'(lambda (i j) (cref image i j)) i1 j1 (floor i1) (floor j1) (ceiling i1) (ceiling j1)))) ; (format t " ~a ~a ~a~%" i2 j2 (aref lmage i2 j2)) )))))9K>#3&& L-UHWVAWAVATASHuI) fffS L-HǰI1 ffS L-VH}1I9 ffS L-VH}HI9 ffffS L-dVHufff%SL-LIA fS L-4VHufff%SL-II fS L-VH}Hffff%0SL-IH}Hfff%0SL-IuE1Hufff%PRL-HuE1Hufffff%PRL-|HLLމ uHH)H% SL-DH}ffff%(SL-,L u Hff%SL-VLL uHH)H&% SL-H}ffff%(SL-_ u HFfff%SL-VLLމ uHH)Hn% SL-dH}ffff%(SL-LL߉ u Hff%SL-$VHufff%SL- VLL uHH)H% SL-_%(SL-_ u Hfff%SL-VAVAWjRjRHH3eH)%eH%eH;%wHCe$%HH-$FFLHFF %hQFMQ H}LVH~#HH~+HVuuHuIY ffS L-VHuIY fffS L-VHuIa fffS L-VHuIa fffS L-_AX8Ii fffffS L-tIq fS L-\_AXH]HC+HIH<LC fffff% RL-,HL@u H~Hf%SL-ILHu%hSL-@ gHL@u HH%SL-ILHu%hSL-@ HuH0A[A\A^A_ÐHH?HH 0.008 (abs a)) (duplicate-image image)) ((> 0.008 (abs (- a pi))) (let ((lmage (make-array (array-dimensions image))) (h (array-dimension image 0)) (w (array-dimension image 1))) (dotimes (i h lmage) (dotimes (j w) (setf (aref lmage i j) (aref image (- h i 1) (- w j 1))))))) (t (%rotate-image image a))))9KA#>3 L-UHVAWAVATASIHuIffS L-Iff%HSL-@ tLA[A\A^A_Ic H}Iffff% SL-tIfS L-\Iff%HSL-D@ zLIfffS L-HǰIffS L-VL1IfffS L-VLHIfffffS L-IuE1Hufff%PRL-HASE1Hu%PRL-tHIH}L uHH)H% SL-<@u HH%SL-VLL uHH)H% SL-@u HIH%SL-_Mffff%8QL-LMH]HC+HIH<LC fff% RL-tL@u H2Hffff%SL-DILHu%hSL-,@ HL@u H8H%SL-ILHu%hSL-@ GHuHA[A\A^A_LHuA[A\A^A_Ic fHH?HHM}ARL1LffffS L-HHIa S L-L uHH)Hnfff% SL-VLHLffS L-HHIa S L-tL uHH)HZfff% SL-DVL1LS L-,HHIa S L- L u HTff%SL-VLHLffS L-HHIa S L-L u HHff%SL-|V Mfff$%xPL-\HHuIi ffS L-<I1 fS L-$I9 fS L- IA fS L-HHuйIq ffS L-Iy fS L-I fS L-I 4%/c fffff}L-|)sHcH) h 0uH]MLHx؃X{NH{CH{5A3@1L;C#/HC+H9*HIH<LC fffff% RL-uuMM$%xPL-LMH]؃{H{H{A@L;C#HC+H9HIH<LC fff% RL-$HL@u HrHf%SL-IHL@u HHf%SL-IHuuL]LeLuL}$%PffHH?HH\NDi,g\l?s:b?aF^M 5M4Mo1L,5t^5We} Q.P5M-%\%?uz'\Ic'DSbR89DLOOP-LIMIT-34442DLOOP-LIMIT-34441BhdDDIMSLPMM0? ????\PYP?Ur?r?5r?r?%r$? r? ur?'r 'rf?WOLBERG-ZOKAI-FFT-REGISTRATIONF6\(defun wolberg-zokai-registration (mask image) (let ((lpm (double-image (logpolar (low-pass mask)))) (lmage (make-array (array-dimensions image))) (1mage (make-array (array-dimensions image) :initial-element nil)) (i0 (+ 0 (floor (array-dimension mask 0) 2))) (i1 (1+ (- (array-dimension image 0) (floor (array-dimension mask 0) 2)))) (j0 (+ 0 (floor (array-dimension mask 1) 2))) (j1 (1+ (- (array-dimension image 1) (floor (array-dimension mask 1) 2))))) (loop for i from i0 below i1 do (loop for j from j0 below j1 do (multiple-value-bind (y x m) (image-max (image-cross-correlation (logpolar (low-pass (copy-rect (list (- i (floor (array-dimension mask 0) 2)) (- j (floor (array-dimension mask 1) 2)) (+ i (floor (array-dimension mask 0) 2)) (+ j (floor (array-dimension mask 1) 2))) image))) lpm)) (setf (aref lmage i j) m (aref 1mage i j) (list y x))))) (values lmage 1mage)))9M#+L-!UHVAWAVATASM IL޹I fffS L-I fS L-I fS L-VHuI fffS L-lHǰI ffS L-LVHuI fffS L-,IjRjRhAWh 0h 0h 0h.0h 0A 0 0 0PI ffS L-VL1LS L-HHI S L-@u H1ffff%SL-|VH}1LfffffS L-\VL1LS L-DHHI S L-$_ uHH)Hfffff% SL-@u HH%SL-VLHLffS L-HHI S L-@u H1ffff%SL-dVH}HLfS L-DVLHLffS L-$HHI S L-_ uHH)Hfffff% SL-@u HH%SL-VLuuLHu uH9 0Mv%fff%PSL-t@ nL}uLHu uH9 0Mv%ff%PSL-4@ M5ARL1LffffS L-HHI S L-L uHH)H&fff% SL-VLHLffS L-HHI S L-tL uHH)Hfff% SL-DVL1LS L-,HHI S L- L u H ff%SL-VLHLffS L-HHI S L-L u Hff%SL-|V Mfff$%xPL-\HHuI! ffS L-<I fS L-$I fS L- HHuйI) ffS L-I1 4%/c fffff5L-)sHcH) h 0uH]MLHx؃X{NH{CH{5A3@1L;C#/HC+H9*HIH<LC fffff% RL-uuM$%xPL-LMH]؃{H{H{A@L;C#HC+H9HIH<LC fff% RL-lHL@u HrHf%SL- (array-dimension image 0) p) (> (array-dimension image 1) p1)) (duplicate-image image) (let ((lmage (make-array (list p p1))) (io (floor (- p (array-dimension image 0)) 2)) (jo (floor (- p1 (array-dimension image 1)) 2))) (dotimes (i (array-dimension image 0) lmage) (dotimes (j (array-dimension image 1)) (setf (aref lmage (+ i io) (+ j jo)) (aref image i j)))))))9O#haOL-UHt rtAPWVs h 0uɸ 0E@%PAWAVATASLe} uHuHuL1IS L-|HHu uH9 0Ov%fff%HSL-L@ uXLHIfS L-$HHu uH9 0Ov%fff%HSL-@ tLA[A\A^A_I c uuMMfffff$%xPL-HǰIffS L-VL1IfffS L-lH} uHH)Hfff% SL- m th0) (dotimes (j w) (if (> (aref r i j) th1) (push (list (expt b (- i (/ h 2))) (* 2 pi (/ (- j (/ w 2)) w))) q))))))))9P$A#|oL-yUHAPWVAWAVATASHVMUARHuIq4%/c ffffUL-H H+ 0~Ht H`VHHuff%(SL-tVH}Hu%(SL-\VH}1IyffS L-image r))) (let ((gg (get-angles t2 t3 (fourier->image r)))) (dolist (g gg (progn (if debug-p (format t "ql ~a ~a~%" ql qs)) (if dry qs (remove-if #'(lambda (k) (/= qs (sixth k))) (remove-if #'(lambda (k) (> (max 16 (* t1 ql)) k)) q :key #'third))))) (if (>= t4 (caar g) 1) ; пока только уменьшение... и то не работат :( (let ((b (pad-image n (shrink-image (caar g) mask)))) (dolist (a (mapcar #'cadr g)) (let* ((p (rotate-image b a)) (z (fourier-correlation! (real-fft-2d! p) f2)) (im (nth-value 2 (image-max z))) (imm (image-mean z)) (m/m (round im imm)) (th1 (* t0 im))) (if debug-p (format t "angle ~a ~a ~a~%" (caar g) (* 180 (/ a pi)) m/m)) (if (> m/m ql) (setf ql m/m qs (caar g))) (if (not dry) (dotimes (k n) (dotimes (l n) (when (< th1 (aref z k l)) (let ((y (mod (+ k (/ n 2)) n)) (x (mod (+ l (/ n 2)) n))) (push (list (- y io) (- x jo) m/m (/ (* a 180) pi) (aref z k l) (caar g)) q)))))))))))))))9Pd#Z88LL-=H~HlHlEUHE1HMEf$% QL-AWAVATAS} u IHu} u IHu؀} u IHuȀ} u IHu} u HHuHuIS L-<1M$%xQL-$IfffffS L- IfS L-IH}1IS L-L uHH)H fff% SL-HHIS L-Vh 0jHHVeH)%eH%eH;%wHCe$%HHwHHjH@VeH)%eH%eH;%wHCe$%HHwH@H}HIfffffS L-L uHH)HN fff% SL-HHIS L-lVMARLHuIS L-DVLHuIfS L-$_I 4%/c ffffL-)sHcH) h 0uH0IfffS L-H}LEȹIfS L-VH vL}AWHr Hvh HvI_ uH9 0Mv%f%PSL-@ t4L@uH 0Mv%!Hfff%PSL- 0@ H Hv H~HuI!fS L-LIfffffS L-lV 0 0eH,%X eH%XfD)8fD)xeo<%H8HheH%HH@HxHpHIAWI)H^ ؃2 IH LfLL۹؃LO LDK ffffAL-H 0eH,% eH%eH;%we$%H{HsHLff%pPL-THL~HHvH ?HHvHHeH%HHeH%HeH%XV#H/ vHHI1fffffS L-VI9S L-HH IAS L-|IHVMARL޹II4%/c L-DH H+ 0~Ht H`VL޹IQfffffS L- VHHIYffS L-VH}Hffff%(SL-V} jRjRh.0AaHHvHvVHIifff%0SL-\HǠff%(SL-DHHAX(IqffffS L-HHHvH uH9 0Ov%%HSL-@ tjHLH1fff% RL-H HvHvL@1ffff% RL-t} |AVE1Hfff%PRL-LHQAVE1Hfff%PRL-$HMLL%8QL-H uH9 0Lv%fff%XSL-@ 'LHffff%0SL-L u Hff%SL-HLIyfffS L-dVLHfffff%0SL-DL u Hff%SL-HLIyfffS L-VHHX uHH)H% SL-VHH8 uHH)H"% SL-VHǠHfff%(SL-dHIi%0SL-LVMLL%8QL-4VHHvv0M ff$%xPL-HHPeH,% eH%eH;%we$%H{HsHHPHL@u HHfff%SL-tILHfff%hSL-T@ /HL@u HH%SL-ILHfff%hSL-@ HH(HHHvH HHHHHvH  } tBjRjRh.0H@HvHHHM IqffffS L-T} tH@HvHPA[A\A^A_HH3eH)%eH%eH;%wHCe$%HH-$FFLHFF %hQFMH@LVH~#HH~+HVjRjRHHCeH)%eH%eH;%wHCe$%HH-$FFLHFF %hQFMHHLELVH~#LF+HH~3HVHPVIH^ ؃HIAX IfffS L-_HPA[A\A^A_Ic HH?HH.?.>LyPOWER-OF-2-CEILING!nI8sSHRINK-IMAGEwa6/( )Eangle ~a ~a ~a~%-MODEql ~a ~a~%L-uaUHWVHuHvVHuIyfffffS L-_ uH9 0Ev%f%@SL-ff?SIXTH,f<QS0?f?f"6t9QD ,FOURIER-MELLIN-SEARCHCL-UHAPWVHuHvH}f%(SL-VH@uH 0Lv%HƀHfff%HSL-@ t HƀHuHHHu uH9 0Ov%fff%HSL-Lff,&#DG34496qQL0?5???"6t9QQ',{P qR,IhcI+b"IaeI7`d IM I IR , V  Q d Wj c myA "_-A ^= ]! \ J[ `Z rY] X6 ] W Y V  K BJ 5A{ -{ )= t  <   6  6 T 6 NWE"+DDo;C" *=GWPWZgMg*:-t-X-&8-5"D-Kzgyw!D _,89gDG34494DG34492p?M/M?IMM?IMDG34481DG34486DG34488DG34487DG34485DG34484DG34480DG34476?GG120lz|mT?DRY?DEBUG-P?T4?T3?T2qrM0?T ] ?R ]  ?P  ?N ?L= ?J ?H ?F  ?DM ?B! ?@= *?B  ?@?>A -?<E ?:kI?8eI?6"I?4"I?2"I?0I?.I?,I?*I?(}II?I?I?I?I? I?vI?eI?TI?TIt{HF6G(defun fourier-search (mask image &key (t0 0.1) (t1 0.9) mask-cooked-p image-cooked-p) (let* ((n0 (power-of-2-ceiling (array-dimension image 0))) (n1 (power-of-2-ceiling (array-dimension image 1))) (io (floor (- n0 (array-dimension image 0)) 2)) (q) (jo (floor (- n1 (array-dimension image 1)) 2)) (m1 (if mask-cooked-p (duplicate-image mask) (treshold-fourier! t0 (pad-image n0 mask n1)))) (f1 (if image-cooked-p (duplicate-image image-cooked-p) (real-fft-2d! (pad-image n0 image n1)))) (z (fourier-correlation! m1 f1)) (th1 (* t1 (nth-value 2 (image-max z))))) (dotimes (k n0 q) (dotimes (l n1) (when (< th1 (aref z k l)) ; (format t "~a ~a ~a~%" k l (aref z k l)) (let ((y (mod (+ k (/ n0 2)) n0)) (x (mod (+ l (/ n1 2)) n1))) (push (list (- y io) (- x jo) (aref z k l)) q)))))))9R3G#=--L L-eH~HlHlEUHE1HMEf$% QL-AWAVATAS} u Ii Hu} u Iq HuH}1Iy fS L-lI fS L-TIH}HIy fffS L-,I fS L-IH}1Iy S L-L߉ uHH)HRfff% SL-HHI S L-Vh 0H}HIy S L-|L uHH)H6fff% SL-LHHI S L-,V} t#HuI fffffS L-FMH}LI ffffS L-H}I ffffS L-V} t#HuI fffffS L->MH}LI ffffS L-lI fS L-TVHpHhI ffS L-,VHVM ARH`I 4%/c ffff L-H H+ 0~Ht H`H}fffff%(SL-VASE1HPfff%PRL-HATE1HHfff%PRL-tHqL`LLfff%8QL-LHX uH9 0Lv%fff%XSL-@ LHffff%0SL-L u Hff%SL-HL޹I fffS L-VLHfffff%0SL-L u Hff%SL-dHLI fffS L-DVH@Hu uHH)H fff% SL- VH8Hx uHH)H*% SL-VL`LLfff%8QL-VMefff$%xPL-HHueH,% eH%eH;%we$%H{HsHHuHL@u HHff%SL-$ILHHfff%hSL-@ HL@u HH%SL-ILHPfff%hSL-@ HuH@A[A\A^A_ÐHH?HH-L1=,(0'UUt7 +5PBOnnKnDo$Ukb8b7? v89gDG34509DG34507p2?M1lm?IMAGE-COOKED-P?MASK-COOKED-PqrM0?0?.Ur ?,o Jp?*Gp?(Ep?&p?$p?"Ep? p?bp?]p p p?vp? vp?vp?ep?Tp?Tp}?FOURIER-SEARCHHF6(defun hough-line-transform (image) "computes Hough transform for lines" (let* ((maxr (ceiling (sqrt (+ (expt (array-dimension image 0) 2) (expt (array-dimension image 1) 2))))) (r0 (/ maxr 2)) (i0 (/ (array-dimension image 0) 2)) (j0 (/ (array-dimension image 1) 2)) (lmage (make-array (list maxr 360)))) (dotimes (i (array-dimension image 0) lmage) (dotimes (j (array-dimension image 1)) (if (not (zerop (aref image i j))) (dotimes (a 360) (let* ((aa (* (/ a 360) 2 pi)) (r (+ (* (- i i0) (sin aa)) (* (- j j0) (cos aa))))) ;(format t "~a ~a~%" a r) (incf (aref lmage (floor (+ r r0)) a) (aref image i j)))))))))9S#L-UHVAWAVATASH}1IffS L-HHIS L-VH}HIffffS L-|HHIS L-\_ u Hfff%SL-4IfS L-IfS L-VHHfffff%0SL-VH}1IffS L-HH%0SL-VH}HIffffS L-HH%0SL-lVuh@ Mfff$%xPL-DHǰIffS L-$VH}1IffS L-VE1Huf%PRL-HaH}HIffffS L-VE1Huf%PRL-HLELLfffff%8QL-|H@uH 0Ev%1%@SL-T@ 'E1LH@ ffff%0SL-$Iff%(SL- ILHu uHH)Hffff% SL-VL޹IffffS L-_%(SL-VLHu uHH)H% SL-tVL޹IffffS L-T_%(SL-D_ u Hfff%SL-VuH}Huȉ u Hf%SL-IfS L-VLELLfffff%8QL-VLEH}Lffff%8QL-HHu u Hfffff%SL-dVH]LELHxfffff%RL-PHH?HHM.L[e*OXeeL/>mtZ?wDG34591DG34593DG34592DG34594089DG34590DG34588h?CENTREDG34582DG34584DG34583DG34581DG345800?*  y?(u?&M?$?"e? ??uJ?J??a?:?%???s  ??P =F6(defun generalized-hough+sobel-transform (r-table image) "computes the generalized Hough tranform, finding edges with Sobel operator" (multiple-value-bind (g q) (sobel image) (let ((lmage (make-array (array-dimensions image) :initial-element nil))) (dotimes (i (array-dimension image 0) lmage) (dotimes (j (array-dimension image 1)) (if (not (zerop (aref g i j))) (let ((a (floor (mod (+ (* (/ (aref q i j) pi) 180) 360) 360)))) (dotimes (u 360) (dolist (p (aref r-table (mod (+ 360 (- a u)) 360))) (let ((c (cos (cadr p))) (s (sin (cadr p)))) (dotimes (f 5) (let* ((r (* (expt 2 (- f 2)) (car p))) (y (floor (- i (* r s)))) (x (floor (+ j (* r c))))) (when (array-in-bounds-p image y x) (if (null (aref lmage y x)) (setf (aref lmage y x) (make-array '(360 5)))) (incf (aref (aref lmage y x) u f)))))))))))))))9V#xxL-UHWVAWAVATASMEARHuI 4%/c EL-)sHcH) h 0uHuI S L-|IjRjRhAWh 0h 0h 0h.0h 0A 0 0 0PI ffS L-,IH}1I S L- VjHuff%PRL-HH}HI ffffS L-VjHuff%PRL-HLEH}Hufff%8QL-H@uH 0Ev%1%@SL-\@ kLEH}Hufff%8QL-4HI %0SL-HǠff%(SL-@uH@ H@ ffff%SL-HH@ I S L-I fS L-VjH}Hu uHH)H% SL-d@uH@ H@ ffff%SL-4HH@ I S L-H}ffff%SL-VHuvHuHvHvI fffffS L-VHuHvHvI S L-\VE1LHsHI fffS L-$VHuHv_f%(SL-VHHpfffff%(SL-H} uHH)HQfff% SL-I fS L-IHhHx%(SL-tH} u HKf%SL-LI fS L-4ILELLI fffS L- @ D؃@A{5I{*I{AAM;s#IC+I9HIIIs Ht@ HǰI I fffS L-\LMLۉ؃{H{H{A@L;C#HC+H9HIH<LC fff% RL-MLL%8QL-VIH}Lfffff%8QL-@ H!Hfff%SL-lVH`LELHXfff%RL-DHHII(HHHuHvHu} HHuHHuHuH@ [HHHu@HH%SL-HuH}Huffff%hSL-@ HHu@HH%SL-THuH}Huffff%hSL-4@ ?LH A[A\A^A_fHH?HH :key #'fifth)) (dotimes (j (array-dimension image 1)) (if (not (null (aref image i j))) (dotimes (k 360) (dotimes (l 5) (if (< treshold (aref (aref image i j) k l)) (push (list i j k l (aref (aref image i j) k l)) r)))))))))9WAX#L-UHWVAWAVATASh 0H}1IfffS L-VE1Huf%PRL-HIH}HIffffS L-tVE1Huf%PRL-\HLELLfffff%8QL-4@ <E1'E1LELLffff%8QL-ILL%8QL-H} uH9 0Lv%fffff%XSL-@ ASATAVAWLELLffff%8QL-ILL%8QL-lV(Mfff$%xPL-LHHueH,% eH%eH;%we$%H{HsHHuII(II@ L@u HH%SL-ILHu%hSL-@ OHL@u H H%SL-tILHu%hSL-\@ jRjRuIH^ ؃HVI H^ ؃HIAXL]LeLuL} I$%QffHH?HH 128 (aref image i j)) 0 255))))))9X4#oL-uUHAWAVATASILIqfffS L-HǰIyffS L-VL1IfffS L-VE1Huf%PRL-lHLHIfffffS L- m (aref a i j)) 0 (aref fft i j))))))))9XrA-#oL-UHWAWAVATASIMMARLIq4%/c fffffML-)sHcH) h 0uHVMARHuйIy4%/c fffL-TH H+ 0~Ht H`H}fffff%(SL-$VL1IfffS L-VE1Huf%PRL-HyLHIfffffS L-IE1Lސ%PRL-HLELLfffff%8QL-|H} uH9 0Ov%fffff%HSL-L@ t1LELLffff%8QL-$LML%RL- L@u HHffff%SL-ILLސ%hSL-@ L@u HHfff%SL-ILHu%hSL-t@ LH A[A\A^A_fHH?HH :key #'fifth))) (list (round (apply #'average (mapcar #'car g))) (round (apply #'average (mapcar #'cadr g))) 1 (round (apply #'average (mapcar #'fourth g))) (round (apply #'average (mapcar #'fifth g))))) (group #'(lambda (a b) (and (> t0 (abs (- (fourth a) (fourth b)))) (> t1 (sqrt (+ (expt (- (first a) (first b)) 2) (expt (- (second a) (second b)) 2)))))) lst :every t)))9X#HL- UHAPWVAWAVATAS 0 0eH,%X eH%XfD)8fD)xeo<%H8HheH%HH@HxHpHIAWM9jRjRHHCeH)%eH%eH;%wHCe$%HH-$FFLHFF %hQFMAH}LELVH~#LF+HH~3HVLEII.0 IQfS L-ID؃McLL؃LOLDK AL-H 0eH,% eH%eH;%we$%H{HsHLff%pPL-4HL~M[A [HuHveH%HHeH%HeH%XHA[A\A^A_<ZfffmdL-UHVAWAVATAS 0 0eH,%X eH%XfD)8fD)xeo<%H8HheH%HH@HxHpHIAWIH^ ؃*IL]D؃McLL؃LOLDK ffffAL-$H 0eH,% eH%eH;%we$%H{HsHLff%pPL-HL~M[A VHuHvHeH%HHeH%HeH%X1M}f$%xQL-|I!fffffS L-dI)fS L-LV 0 0eH,%X eH%XfD)8fD)xeo<%H8HheH%HH@HxHpHIAWI1H^ ؃IL]D؃McLL؃LO~LDK ffffAL-H 0eH,% eH%eH;%we$%H{HsHLff%pPL-RHH?HHC>I>tOLz/>Rr>XoReen>Q[d)><);)!:s/9)r$.rq0))?)?)"69Y,p7<, " GDG34659DG34689DG34660DG34658DG34657qr0 O 7|?us? ? ? F6s(defun compare-complex (image image1) (dotimes (i (array-dimension image 0)) (dotimes (j (array-dimension image 1)) (let ((d (abs (- (aref image i j) (aref image1 i j)))) (m (min (abs (aref image i j)) (abs (aref image1 i j))))) (if (> (if (zerop m) d (/ d m)) 0.001) (format t "~a ~a ~a ~a ~a ~a~%" (aref image i j) (aref image1 i j) i j d m))))))9Y>s#L-eUHWVAWAVATASH}1IfS L-VE1Huf%PRL-HH}HIffffS L-|VE1Huf%PRL-dHiLELLfffff%8QL-d%$k~'G2:*070 - - M  y 0  ?i? ui? ]i'i?'iROTATE-RECT-POINTSF6N(defun rotate-roints (a rect) (let* ((c (cos a)) (s (sin a))) (values (%rotate-point c s (new-point (first rect) (second rect))) (%rotate-point c s (new-point (first rect) (fourth rect))) (%rotate-point c s (new-point (third rect) (fourth rect))) (%rotate-point c s (new-point (third rect) (second rect))))))9ZN#~L--UHWAWAVATASMIHuIffS L-VHuIfffS L-VDMgDIwL^eH,% eH%eH;%we$%LcL[HH}LEйLS L-VDaMgDVIwLHvBHv8L^eH,% eH%eH;%we$%LcL[HH}LEйLfffS L-dVDIwHvLfDIwHvHvL^eH,% eH%eH;%we$%LcL[HH}LEйLS L-VDAIw7Hv-LfD"IwL^eH,% eH%eH;%we$%LcL[HH}LEйLfffS L-V L]LeLuL}$%Pex%7 m+./,'9 Me9DLmKm$Jl Q }eQed*70   Q Q I} } x? e9? E9'9?'9?ROTATE-ROINTSF6(defun restore-rect (rect a o image) (let ((p (multiple-value-list (rotate-rect-points a rect)))) (let ((li (mapcar #'point-i p)) (lj (mapcar #'point-j p)) (h (array-dimension image 0)) (w (array-dimension image 1)) (hr (- (third rect) (first rect))) (wr (- (fourth rect) (second rect)))) (let ((maxi (min (1- h) (max 0 (+ (point-i o) (apply #'max li))))) (mini (min (1- h) (max 0 (+ (point-i o) (apply #'min li))))) (maxj (min (1- w) (max 0 (+ (point-j o) (apply #'max lj))))) (minj (min (1- w) (max 0 (+ (point-j o) (apply #'min lj)))))) (if (and (not (zerop (- maxi mini))) (not (zerop (- maxj minj)))) (let* ((ar (copy-rect (list mini minj maxi maxj) image)) (r (rotate-image (pad-image (max (- maxi mini) (- maxj minj)) ar) (- (/ (* a pi) 180)))) ; хрень с углом (r0 (array-dimension r 0)) (r1 (array-dimension r 1)) (i0 (max 0 (round (- (/ r0 2) (/ hr 2))))) (i1 (min r0 (round (+ (/ r0 2) (/ hr 2))))) (j0 (max 0 (round (- (/ r1 2) (/ wr 2))))) (j1 (min r1 (round (+ (/ r1 2) (/ wr 2)))))) (pad-image hr (copy-rect (list i0 j0 i1 j1) r) wr)))))))9[#|n!L- 5Hl$Hl$EAPWVAWAVATASMUARH}HuIi4%/c UL-Mmff$%xPL-V 0 0eH,%X eH%XfD)8fD)xeo<%H8HheH%HH@HxHpHIAWIqH^ ؃jIL]D؃WMsLL؃LO>LDK ffffAL-H 0eH,% eH%eH;%we$%H{HsHLff%pPL-|HL~M[A VHuHvHeH%HHeH%HeH%XV 0 0eH,%X eH%XfD)8fD)xeo<%H8HheH%HH@HxHpHIAWIyH^ ؃3IL]D؃ MsLL؃LOLDK fffffAL-|H 0eH,% eH%eH;%we$%H{HsHLff%pPL-,HL~M[A UHuHvHeH%HHeH%HeH%XVH}1IfffS L-VH}HIffffS L-VHu Hv Hv HvVHu Hv_ uHH)H fff% SL-$VHu Hv Hv Hv HvVHu Hv Hv_ uHH)H % SL-VHu@u H Hfff%SL-TIL}D IwVHu1Mf$%xQL-IfffffS L-_ u H fff%SL-IL@uH 0Lv%1Hff%HSL-@ t1LILL uH9 0Lv%fff%XSL-l@ tLLVHu@u H Hffff%SL-,IL}D IwVHu1Mf$%xQL-IfffffS L-_ u Hn fff%SL-IL@uH 0Lv%1Hff%HSL-@ t1LILL uH9 0Lv%fff%XSL-D@ tLLVHu@u H" Hffff%SL-IL}DO IwVHu1M-f$%xQL-IfffffS L-_ u H fff%SL-IL@uH 0Lv%1Hff%HSL-\@ 1LILL H9 0Lv%f%XSL-@ LLVHu@H H%SL-IL}D IwVHu1Mef$%xQL-IfffffS L-|_ H ffff%SL-LIL@H 0Lv%1Hfff%HSL-@ 1LILL H9 0Lv%fffff%XSL-@ LLIH}Hx HH)H ffff% SL-lH@H 0Ev%1f%@SL-<@ ]HpLމ HH)H fff% SL-H@H 0Ev%1f%@SL-@ xASup Mm ff$%xPL-HHuIffS L-lVH}Hx HH)H} fff% SL-,IHpLމ HH)H fff% SL-ILL H9 0Ov%ff%HSL-@ LLHHhIffS L-|VIHuffff%(SL-\HHƠ%0SL-Df%SL-4_IS L-IL1IfS L-ILHIfffS L-ILHfff%0SL-VH}Hffff%0SL-_ HH)Hh % SL-dIfS L-LVH@H 0Lv%1Hffff%HSL-@ 1H`HVAVLH%0SL-VH}Hffff%0SL-_ Hffff%SL-IfS L-tVHXHP H9 0Lv%fff%XSL-4@  HXHPHVLHffff%0SL-VH}Hffff%0SL-_ HH)H`% SL-IfS L-VH@H 0Lv%1Hffff%HSL-T@ 1HPHVAWLH%0SL-VH}Hffff%0SL-_ Hffff%SL-IfS L-VHHH@ H9 0Lv%fff%XSL-t@  HHH@HV`PXH Mfff$%xPL-HLIfffS L-HHuLEHxA[A\A^A_Ic 0HPA[A\A^A_ffͦ  ͦ>\asHH?HH'u>h}>9T >DF ++Zhs49NEM<D \ ,   t % D  $ / M l / L  2 !1 $,  d F w T F H F n  uT RgT YfO-=7N!,L$gw[f*R"/)!])\E`BDG34798DG34797DG34796DG34794DG34793hDG34792 0DG34790DG34789?AR^DG34788DG34786DG34787]DG34784DG34782DG34783`DG34780DG34778DG34779_DG34776DG34774DG34775?WRHRV?LJDG34768DG34770DG34769DG34767DG34766?LIDG34761DG34763DG34762DG34760DG34759O70+?,+?.M?,?*+?*u?( +?* ?( ?& +?&  / + + + d  d ?$ + T > T  ;N7T ?">w? >O?>d'd?}>?>?]>?5>?>Q 9 5??>  ??u>?)>?)>?)>?)>?RESTORE-RECTF6(defun dilate-points (pts) (remove-duplicates (apply #'append (mapcar #'(lambda (p) (let ((i (point-i p)) (j (point-j p))) (list p (new-point i (1+ j)) (new-point (1+ i) j) (new-point (1+ i) (1+ j))))) pts)) :test #'equal))9\@#ƾ>L-UHVAWAVATAS 0 0eH,%X eH%XfD)8fD)xeo<%H8HheH%HH@HxHpHIAWML]D؃<McLL؃LO#LDK ffAL-tree *scripts*))9].L-UHI 0IfffffS L-@ }IH^ ؃u~HVI HK*1eH; %@CeH%HH4BHDstO_IffS L-TIIc 0ffMͦf͓fff*OAK*h(%|,F-F^#*F6(defvar *frg* (slurp #'alist->hash (pathify "freq-" '("welsh" "english" "latin" "russian" "ukrainian"))))9]@oL-UHI 0IfffffS L-@ uqIH^ ؃urHVIIIfffS L-|_I S L-dIIc 0ffIͦfff?*FRG*uEfreq-,EwelshEenglishElatinErussianEukrainian"%|,Bn[)mbi:l[b29BZ&,F"6(defvar *lng* #((2 . 0) (2 . 1) (2 . 2) (3 . 3) (3 . 4)))9]:@9)?*LNG*          F6(defun set-acorn! () (setf *acorn* (slurp #'identity *scripts*)) t)9]IG#L-UHIH^ ؃}HVIHK*1eH; %@CeH%HH4BHDstN_IfS L-Iff%TL-l.0fͦ7͓fff1(%),B|%A/,7-SET-ACORN!F6(defun set-oak! () (setf *oak* (slurp #'grafs->tree *scripts*)) (when *acorn* (set-acorn!)))9][@`##L-UHIH^ ؃HVIHK*1eH; %@CeH%HH4BHDs_I!ffffS L-|I)ff%TL-dI1HN*1eH; %@CeH%HHBHD^t6 t 1I9c 0Ðͦ7͓͖h(%+).,D_R^A!@/(60?SET-OAK!/F6(defun img<-path (path) (instantiate-rectangle (shrink-lst 10 (widen-lines 1 (render-svg-path path)))))9]sn#L-uuUHVIfffS L-HIffS L-HPIffS L-Ic fff06>,|ml6lLEk,Tj/0?|1?IMG<-PATHF"6(defvar *plant* t)9])*PLANT*F6(defun remember-blocks (i blocks &optional (stream t)) (let* ((graph (blocks->graph blocks)) (c (read stream))) (push (list (etypecase c (character c) ((integer 0 9) (digit-char c)) (string (char c 0)) (symbol (char (symbol-name c) 0))) graph) (svref *acorn* i)) ; (format t "r ~a~%" (length *acorn*)) (setf (svref *oak* i) (grafs->tree (svref *acorn* i))) (when *plant* ;добавлять только новое? (grafs->file (svref *acorn* i) (svref *scripts* i))) graph))9]#cTOL-UHt rtAPWVs h 0uɸ 0E@%PAWAVATASLe} u .0HuHuIS L-|VHuIfffS L-\IMAHuLmMAuM|IH 0Nv% 0 0@ tL޹IS L- AVHuuFLkI0u/HuHvHHHHHHH 0Dv%IH 0Dv%H@ t&L1IffffS L-lMA tD 0Dv%.0@ t=L޹IfS L-$H1IfffS L-+ILIf%@QL- 0VuMEfff$%xPL-VIHK*1eH; %@CeH%HL<ABLD{AOMDuAG;A9IGHHI9,Kt7H}eH,% eH%eH;%we$%H{HsHVMLHuDuA@@I@HHH9fff% RL-HIHK*1eH; %@CeH%HH4BHDs~VIHK*1eH; %@CeH%HH<BHD{NuG?A=HGHHI90Jt'IfffS L-LAXDuA@@I@HHH9fff% RL-IHN*1eH; %@CeH%HHBHD^ IHK*1eH; %@CeH%HH<BHD{ruGcAaHGHHI9TJt'VIHK*1eH; %@CeH%HH<BHD{uGAHGHHI9Jt'_IfffS L-THuHA[A\A^A_ffT͓߶ ض",x_͓͓׶!ض:Dxs͖͓׶&͓V׶mwO?DIGIT-CHARj,O?CHARACTER,?INTEGER /?SYMBOL)+h2(s,j9l XlXn{Xx))s DG34877DG34879DG34878DG34880DG34889DG34887DG34886DG34883DG34881*u0?XXX?MX!s? s) ??j?[ [3REMEMBER-BLOCKS;F6 (defun forget-last (i) (pop (svref *acorn* i)) (setf (svref *oak* i) (grafs->tree (svref *acorn* i))) (grafs->file (svref *acorn* i) (svref *scripts* i)))9^#}L-UHAWAVATASMIIN*1eH; %@CeH%HL$ABMDfAMDuAD$AID$HHI9CtHu؉vMLHuDuA@o@mI@HHH9`fff% RL-HIHK*1eH; %@CeH%HH4BHDsVIN*1eH; %@CeH%HH<BID~uGAHGHHI9Jt?IffS L-blocks img) stream))9^Cb#L-UHt rtAPWVs h 0uɸ 0E@%P} u .0HuHuIfffS L-HHuLEIc f{4,^3a^FYz0?^?O?O6REMEMBER-IMG;F61(defun stierlitz (image blocks) (let ((lmage (make-array (array-dimensions image) :initial-element 0))) (loop for b in blocks for c in '(1 2 3 4 5 6 7 8 9 a b c d e f g h i j k l m n o p q r s t u v w x y z) do (dolist (p (fourth b)) (setf (aref lmage (point-i p) (point-j p)) c))) lmage))9^\1#bL-uUHWVAWAVATASHuI fffS L-IjRjRhAWh 0h 0jh.0h 0A 0 0 0PIffffS L-tIh 0uA 0AHu@ HuHvHuHuHvHuHuL^HuHvHuHuȉHvHvHvyvHugL~MDYIvVMDJIvHLAXL؃5{+H{ H{A@L;C# HC+H9HIH<LC % RL-HuHvHu} "HHu@ t5HuHvHuHuHvHuHu@ tmHHLA[A\A^A_Ð&@Ulͳ˃s"Ry,         *VgRT089,"0sn%$R#iRhDG34905DLOOP-LIST-34904*DLOOP-LIST-34903DDIMSu0lUhR?7?o o?s? s ???8STIERLITZF62(defun test-img (i image) (let ((blocks (image->blocks image))) (values (stierlitz image blocks) blocks (gather-fruit (svref *oak* i) (blocks->graph blocks)))))9^#(L-UHWVAWHuI9fS L-IH}LIAS L-VAWIIHK*1eH; %@CeH%HH<BHD{HuuGut@uvHGHHH9smHt7VLIQS L-$_IYS L- VL}$%P^͓׶gfff{9+Ov,7FWzW7TTlu07??:TEST-IMGF6(defun test-slice (i no &key box) (test-img i (nth no (funcall (if box #'boxify #'carve-into-boxes) *omg*))))9^o#eLL-qH~HlHlEUHE1HMEf$% QL-AWAVATL}MDuAD$LkMu.0I 0Dv%@ t.L@uH 0Mv%1fff%PSL-D 0@ tL.ILI)I1fffffS L-V} tI9H^ ؃mHIAH^ ؃WHVIIHK*1eH; %@CeH%HH4BHDs$H]؃LOLDK fffAL-\HILeE1Lff%PRL-,H~qDIvI@ u 0QL@u HHffff%SL-ILL%hSL-@ tLHHvH}A\A^A_IQc  ͦ(ͦE͓~ͶHH?HH0M MQ?Qn YV?R}?R}?R}@?PROVE-SLICEHF6L(defun approve-slice (i no &key box) (multiple-value-bind (k b c) (test-slice i no :box box) (format t "~%~a~%~a~%~a~%" k b c) (when (or (null c) (not (zerop (caar c)))) (remember-blocks i b))))9_#2LL-YH~HlHlEUHE1HMEf$% QL-AWMARjRjRuLEIHu I4%/c ffffL-l)sHcH) h 0uL}jRjRh.0ALEH}L(IfffS L-A tHDutIwunH~@uH 0Ev%1%@SL-@ tH}HuHA_Ic 0HA_fff==?E~%~a~%~a~%~a~%4,Ne'e:X::cm}ND^*b>0e? e? e?Ne?Ne?NeA?APPROVE-SLICEHF69(defun grayscale->bitmap! (image) (dotimes (i (array-dimension image 0) image) (dotimes (j (array-dimension image 1)) (setf (aref image i j) (round (aref image i j) 255)))))9_D#OL-UHAWAVATASIL1IqfS L-VE1Huf%PRL-H9LHIqfffffS L-|IE1Lސ%PRL-dHMLL%8QL-DHHIyS L-$LML%RL- L@u HHffff%SL-ILLސ%hSL-@ _L@u HHfff%SL-ILHu%hSL-t@ LHA[A\A^A_fHH?HHBITMAP!F6(defun haar-decomposition-step (h c) "переписал буквально" (if (<= h 1) c (let ((c/ (copy-seq c)) (half (/ h 2))) (haar-decomposition-step half (dotimes (i half c/) (let ((2i (* i 2)) (2i+1 (1+ (* i 2))) (v2 (sqrt 2))) (setf (svref c/ i) (/ (+ (svref c 2i) (svref c 2i+1)) v2)) (setf (svref c/ (+ half i)) (/ (- (svref c 2i) (svref c 2i+1)) v2))))))))9_x#YTL-UHWAWAVATASIH}@uH 0Nv%Hffff%`SL-@ t LA[A\A^A_LIfffS L-|VH}Hffff%0SL-\VLeuE1Huff%PRL-L-YUHVAWAVATASIL1IS L-HǰIffS L-IL1IfS L-IE1Lސ%PRL-lHMLHufffff%8QL-DLMDuA@@I@HHH9fff% RL-L@uHpjHf%SL-ILLސ%hSL-@ GLA[A\A^A_fضxHH?HH_MLf%RL-tIHuI9|LHA[A\A^A_ffD޶Y_fff,% bB>aDuU`DG3497400@?= % %%M,JF6(defun (setf col) (c image j) (dotimes (i (length c) c) (setf (aref image i j) (svref c i))))9`c#L-UHAWAVATASIIMLffff%pSL-VE1NAWDuAFu`AubIFHHI9sYKt>LAXL%RL-tIHuI9|LHA[A\A^A_ffD޶Y_fff,% bB>aDuU`DG34980*0@?= % %%N,LF6(defun haar-standard-decomposition! (image) (dotimes (i (array-dimension image 0)) (setf (row image i) (haar-decomposition (row image i)))) (dotimes (j (array-dimension image 1)) (setf (col image j) (haar-decomposition (col image j)))) image)9`#`L-!UHAWAVATASMIL1IffS L-IE1L%PRL-HAVAWLLI fffffS L-tLffffS L-\IH}HuйIfffffS L-4HL@u HRHf%SL-ILL%hSL-@ GLHIffffS L-IE1L%PRL-HAVAWLLIfffffS L-tLffffS L-\IH}HuйI!fffffS L-4HL@u HHf%SL-ILL%hSL-@ GLA[A\A^A_fHH?HHz Uy^x<\ # '!eNDv,898DG350569DG35054?COEF0 7?  H? E?''ZDRANSFORM!F6(defun distance-transform! (image) (dransform! image #'coef-1))9b1?# L-u5UHVIYH^ ؃u#HH}Iac ͦfffU[,=#>)5=0?=\?DISTANCE-TRANSFORM!F6(defun chamfer-transform! (image) (dransform! image #'coef-2))9bB># L-u5UHVIYH^ ؃u#HH}Iac ͦfffW[,="=)4<0?=]CHAMFER-TRANSFORM!F6|(defun image-not (image) (let ((tmp (make-array (array-dimensions image) :element-type '(unsigned-byte 8)))) (dotimes (i (array-dimension image 0) tmp) (dotimes (j (array-dimension image 1)) (setf (aref tmp i j) (- 1 (aref image i j)))))))9bR#L-UHAWAVATASILIfffS L-IjRjRh8AWh 0h 0h 0h 0h 0A 0 0 0PIffS L-tVL1I fffS L-TVE1Huf%PRL-v,DG35073DG35071DDIMS0> >? ?? _IMAGE-NOTF6y(defun h (image dform) ; (apply ; #'max ; (map 'list #'* ; (make-array ; (array-total-size image) ; :element-type (array-element-type image) ; :displaced-to image) ; (make-array ; (array-total-size dform) ; :element-type (array-element-type dform) ; :displaced-to dform)))) (let ((d 0)) (dotimes (i (array-dimension image 0) d) (dotimes (j (array-dimension image 1)) (if (and (not (zerop (aref image i j))) (< d (aref dform i j))) (setf d (aref dform i j)))))))9b#\L-UHAWAVATASIIjL1IfffS L-VE1Huf%PRL-HLHIfffffS L-tVE1Huf%PRL-\HMLL%8QL-B%>GrMqep @$?`w$#"!``KW >J>J-5&$,$,DG35098DG35097B_*b 0O\?[BWB 9 5?$?"? ? ? ? dHAF6c(defun ht (image dform) (let ((d 0) (c 0)) (dotimes (i (array-dimension image 0) (/ d c)) (dotimes (j (array-dimension image 1)) (if (not (zerop (aref image i j))) (setq d (+ d (aref dform i j)) c (1+ c)))))))9d/#vL-UHVAWAVATASIjjL1IfffS L-VE1Huf%PRL-HLHIfffffS L-tIE1Lސ%PRL-\H MLL%8QL-NDG35129DG35128i j0? N? N? !N?!N?!N?!N?!N?!Np?HR-DISTANCE<F6(defun hausdorff-distance (i1 i2) (h-distance i1 (chamfer-transform! (image-not i1)) i2 (chamfer-transform! (image-not i2))))9d#L-UHWVjRjRuHuIfffS L-IfS L-VHuIfffS L-IfS L-tH}AX I$%Qfff`^k,$UaUtuT3V