Code
| Author: | Mitch Richling |
| Updated: | 2023-10-14 |
Copyright 2023 Mitch Richling. All rights reserved.
Table of Contents
1. Code Library
This is code used by other org-mode files to generate content.
These need reevaluated when the content of the tables data.org:pfdat or data.org:loc2id change.
;; ltable -- a list of lists data structure used to represent an org-table. (defun BWS-ltable-to-org-table-string (ltable) (mapconcat (lambda (x) (concat "|" (string-join (if (listp x) x (list x)) "|") "|")) ltable "\n")) (defun BWS-ltable-sort (ltable col-num lessthan-test) (cl-sort ltable (lambda (x y) (funcall lessthan-test (elt x col-num) (elt y col-num))))) (defun BWS-ltable-search (ltable col-num item equal-test) (cl-remove item ltable :test (lambda (x y) (not (funcall equal-test x (elt y col-num)))))) (defun BWS-ltable-get-col (ltable col-num) (mapcar (lambda (x) (elt x col-num)) ltable)) (defun BWS-ltable-search-cell (ltable key-col-num val-col-num key-val) "Search for a row with a string-equal test on data in column key-col-num and the key-val, and return value in column val-col-num" (or (elt (cl-find key-val ltable :test (lambda (x y) (string-equal x (elt y key-col-num)))) val-col-num) "")) (defun BWS-ltable-stringafy (ltable) "Convert elements in an ltable to strings -- org-mode has a habit of converting numeric looking things to lisp numbers" (mapcar (lambda (x) (mapcar (lambda (y) (format "%s" y)) x)) ltable)) ;; Utility functions (defun BWS-factor-alist (in-table factor-col data-col) (cl-loop for key in (cl-remove-duplicates (BWS-ltable-get-col in-table factor-col) :test #'string-equal) collect (cons key (BWS-ltable-get-col (BWS-ltable-search in-table factor-col key #'string-equal) data-col)))) (defun BWS-string-for-table-cell-from-list (in-list break-count) (string-join (cl-loop with n = (length in-list) for e in in-list for i from 1 for p = (format "%s" e) collect (if (and (not (= n i)) (zerop (mod i break-count))) (concat p " {{{NLTBC}}}") p)) " ")) (defun BWS-id-to-id-type(in-id) (replace-regexp-in-string "[0-9]+$" "" in-id)) (defun BWS-id-match-type (in-type in-id ) (string-equal in-type (replace-regexp-in-string "[0-9]+$" "" in-id))) (defun BWS-ids-same-typep (in-id1 in-id2) (string-equal (BWS-id-to-id-type in-id1) (BWS-id-to-id-type in-id2))) (defun BWS-pos-to-link (n sheet-fmt) (let ((pos (if (numberp n) n (string-to-number n))) (sno (if (= sheet-fmt 150) "w" "u")) (n (format "%s" n))) (if (zerop pos) n (if (string-match "\\*" n) (replace-regexp-in-string "\\*$" "" n) (format "[[file:sheet%s001.html#bwIDsheet%s001p%03d][%d]]" sno sno pos pos))))) (defun BWS-stamp-loc-to-file-base (stamp-location) (if (string-equal "C" (substring stamp-location 0 1)) "album" "stock")) (defun BWS-stamp-id-to-file-base (stamp-id) (BWS-stamp-loc-to-file-base (BWS-id2loc stamp-id))) (defun BWS-stamp-id-to-link (stamp-id) (format "[[file:%s.html#%s][%s]]" (BWS-stamp-id-to-file-base stamp-id) stamp-id stamp-id)) (defun BWS-stamp-id-to-thm-local-link (stamp-id) (if (string-equal (substring stamp-id 0 7) "bwIDp2s") (format "[[#%s][file:%s-X-front-back_90dpi.png]]" stamp-id stamp-id) (format "[[#%s][file:%s-1_90dpi.png]]" stamp-id stamp-id))) (defun BWS-stamp-id-to-thm-link (stamp-id) (if (string-equal (substring stamp-id 0 7) "bwIDp2s") (format "[[file:%s.html#%s][file:%s-X-front-back_90dpi.png]]" (BWS-stamp-id-to-file-base stamp-id) stamp-id stamp-id) (format "[[file:%s.html#%s][file:%s-1_90dpi.png]]" (BWS-stamp-id-to-file-base stamp-id) stamp-id stamp-id))) (defun BWS-loc-to-parts (in-loc) (if (stringp in-loc) (cons (substring in-loc 0 1) (mapcar #'string-to-number (split-string (substring in-loc 2) "[prc]" 't))))) (defun BWS-loc-lessp (in-loc1 in-loc2) (if (BWS-loc-same-book in-loc1 in-loc2) (cl-loop for c1 in (cdr (BWS-loc-to-parts in-loc1)) for c2 in (cdr (BWS-loc-to-parts in-loc2)) when (< c1 c2) return t when (> c1 c2) return nil finally return nil) (string-lessp in-loc1 in-loc2))) (defun BWS-loc-same-book (in-loc1 in-loc2) (string-equal (substring in-loc1 0 1) (substring in-loc2 0 1))) (defun BWS-thk-to-m-pm (measures-string) "Compute mean & standard deviation, and produce a nice LaTeX string." (let ((measures (mapcar #'string-to-number (split-string measures-string nil 't)))) (let ((n (length measures)) (s1 (float (apply #'+ measures))) (s2 (float (apply #'+ (mapcar (lambda (x) (* x x)) measures))))) (format "\\(%0.1f\\pm %0.2f\\,\\mathrm{microns}\\)" (/ (* 1.0 s1) n) (sqrt (/ (- (* n s2) (* s1 s1)) (* n (1- n)))))))) (defun BWS-perf2cperf (h v) "Round to nearest 1/4 perf value, and produce a nice LaTeX string." (interactive "nHorizontal: \nnVertical: ") (let ((h (if (numberp h) h (string-to-number h))) (v (if (numberp v) v (string-to-number v)))) (cl-flet ((r2q (x) (let* ((wp (truncate x)) (tf (round (- (* 4 x) (* wp 4)))) (bf 4)) (cond ((= tf 0) (format "%d" wp)) ((= tf 2) (if (zerop wp) (format "\\frac{%d}{%d}" (/ tf 2) 2) (format "%d \\frac{%d}{%d}" wp (/ tf 2) 2))) ((= tf 4) (format "%d" (1+ wp))) ('t (if (zerop wp) (format "\\frac{%d}{%d}" tf 4) (format "%d \\frac{%d}{%d}" wp tf 4))))))) (if (< h 0.125) (if (< v 0.125) (format "Imperforate") (format "\\(%s\\) Vertically" (r2q v))) (if (< v 0.125) (format "\\(%s\\) Horizontally" (r2q h)) (let ((hs (r2q h)) (vs (r2q v))) (if (string-equal hs vs) (format "\\(%s\\)" hs) (format "\\(%s \\times %s\\)" hs vs)))))))) (defun BWS-pfid2pretty (pfid) (format "=%s=: %s" pfid (BWS-ltable-search-cell pfdat 0 1 pfid))) (defun BWS-ppfid2pretty (ppfid) (format "=%s=: (POTENTIAL) %s" ppfid (BWS-ltable-search-cell ppfdat 0 1 ppfid))) (defun BWS-id2loc (sid) (BWS-ltable-search-cell loc2id 1 0 sid)) ;; Burelage functions (defun BWS-find-burelage-match (pat) "Given a burelage pattern, produce a list of matches. Each match is a list with three values: univeral position, position on 150, position on 168. Example patterns: - A block of four ......... '((1 2) (3 4)) - A horizontal stip of 5 .. '((1 2 3 4 5)) - A vertical stip of 3 .... '((1) (2) (3)) - An irregular block ...... '((1 2 0) (0 3 4)) Note the use of 0 as a wild card -- it effectively matches any type - Ambiguous block ......... '((13 2) (3 4)) The use of 13 here indicates the upper left position may be a 1 OR 3. One might use 13 if all they can tell about the background is that the 'triangle' is at the top of the stamp. In general, the individual digits are taken as allowable types to match. For example, 123 means to match 1, or 2, or 3." (cl-labels ((getbt (x y) (elt (elt burl150168 y) x)) (i2rt (ty) (if (numberp btype) (cond ((= 1 btype) "I") ((= 2 btype) "II") ((= 3 btype) "III") ((= 4 btype) "IV") (t "")) "")) (patmat (x y pat) (cl-loop for ptl in pat for py from 0 when (not (cl-loop for ptv in ptl for px from 0 for bt = (getbt (+ x px) (+ y py)) ;; when (or (null bt) (not (or (zerop ptv) ;; (and (< ptv 5) (equal bt ptv)) ;; (cl-some (lambda (x) (equal bt (- x 48))) (number-to-string ptv))))) when (or (null bt) (not (cl-some (lambda (x) (let ((v (- x 48))) (or (zerop v) (equal bt v)))) (number-to-string ptv)))) return nil finally (cl-return t))) return nil finally (cl-return t)))) (let ((pat-wid (apply #'max (mapcar #'length pat))) (pat (if nil ;; Set to 't to rotate pattern 180 degrees (reverse (mapcar #'reverse pat)) pat))) (cl-loop for y from 0 upto (1- 15) append (cl-loop for x from 0 upto (1- 12) for p = (+ 1 (* y 12) x) for p168 = (if (> y 0) (+ 1 (* (1- y) 12) x) "-") for p150 = (if (< (+ pat-wid x) 11) (+ 1 (* y 10) x) "-") for mat = (patmat x y pat) when mat collect (list p p150 p168)))))) (defun BWS-find-all-burelage-multiples (multiple-width) ;; Shape: 2=2x2, 4=4x1, 1=1x4 "Find all multiples of 4 (2x2, 1x4, 4x1) with all 4 burelage types" (cl-labels ((perms (in-list) (if (null in-list) '(()) (mapcan (lambda (e) (mapcar (lambda (p) (cons e p)) (perms (cl-remove e in-list :count 1 :test #'eq)))) in-list))) (l2pat (in-list) (cl-case multiple-width (4 (list in-list)) (1 (mapcar #'list in-list)) (2 (list (list (elt in-list 0) (elt in-list 1)) (list (elt in-list 2) (elt in-list 3))))))) (let ((all-blocks (perms '(1 2 3 4)))) (sort (mapcan (lambda (x) (mapcar #'car (BWS-find-burelage-match (l2pat x)))) all-blocks) #'<)))) (defun BWS-make-burelage-table (color-function) "Draw a colorfull burelage table" (concat "#+ATTR_HTML: :rules all solid #ccc :frame all :align center :cellpadding 0 :border-spacing 0\n" "| /150/ | *1* | *2* | *3* | *4* | *5* | *6* | *7* | *8* | *9* | *10* | | | |\n" "| <c> | <c> | <c> | <c> | <c> | <c> | <c> | <c> | <c> | <c> | <c> | <c> | <c> | <c> |\n" (BWS-ltable-to-org-table-string (cl-loop for row in burl150168 for y from 0 collect (append (list (format "*%d*" (1+ y))) (cl-loop for btype-num in row for x from 0 for p = (+ 1 (* y 12) x) for btype-str = (if (numberp btype-num) (cl-case btype-num (1 "I") (2 "II") (3 "III") (4 "IV")) " ") collect (if (and (> x 9) (= y 0)) " " (format "{{{%s(%s)}}}" (concat "BCB" (funcall color-function p)) btype-str))) (list (if (= y 0) " " (format "*%d*" y)))))) "\n" "| | *1* | *2* | *3* | *4* | *5* | *6* | *7* | *8* | *9* | *10* | *11* | *12* | /168/ |\n")) (defun BWS-make-burelage-hits-table (pat-shape hit-list) (let ((bloc (cl-loop for mul-pos in hit-list append (cl-loop for tst-pos from 1 upto 180 for tst-pos-x = (mod (1- tst-pos) 12) for tst-pos-y = (truncate (1- tst-pos) 12) for mul-pos-x = (mod (1- mul-pos) 12) for mul-pos-y = (truncate (1- mul-pos) 12) when (not (cond ((< tst-pos 1) "off sheet<") ((> tst-pos 180) "off sheet>") ((= tst-pos 11) "off sheet 11") ((= tst-pos 12) "off sheet 12") ((< tst-pos-y mul-pos-y) "above block") ((< tst-pos-x mul-pos-x) "left of block") ((> tst-pos-y (1- (+ mul-pos-y (length pat-shape)))) "below block") ((> tst-pos-x (+ mul-pos-x (1- (length (elt pat-shape (- mul-pos-y tst-pos-y)))))) "right of block"))) collect tst-pos)))) (BWS-make-burelage-table (lambda (p) (cond ((member p hit-list) "P") ((member p bloc) "Y") ('t "W")))))) (defun BWS-make-burelage-report (multiple-width) (let ((bta (list "-" "I" "II" "III" "IV"))) (concat "#+ATTR_HTML: :border 2 solid #ccc :frame hsides :align center\n" "| 150 | | | | 168 | | | | Types | | | |\n" "| $P_{LU}$ | $P_{RU}$ | $P_{LL}$ | $P_{RL}$ | $P_{LU}$ | $P_{RU}$ | $P_{LL}$ | $P_{RL}$ | LU | RU | LL | RL |\n" "|----------+----------+----------+----------+----------+----------+----------+----------+-------+-----+-----+-----|\n" "| <c> | <c> | <c> | <c> | <c> | <c> | <c> | <c> | <c> | <c> | <c> | <c> |\n" "| / | | | > | < | | | > | < | | | > |\n" (BWS-ltable-to-org-table-string (BWS-ltable-stringafy (cl-loop for pos in (BWS-find-all-burelage-multiples multiple-width) for pos-x = (mod (1- pos) 12) for pos-y = (truncate (1- pos) 12) for blk-pos = (cl-loop for yd from 0 upto (1- (/ 4 multiple-width)) append (cl-loop for xd from 0 upto (1- multiple-width) for x = (+ pos-x xd) for y = (+ pos-y yd) for p = (+ 1 (* y 12) x) for p168 = (if (> y 0) (+ 1 (* (1- y) 12) x) 0) for p150 = (if (< x 10) (+ 1 (* y 10) x) 0) for bt = (elt (elt burl150168 y) x) collect (list p150 p168 bt))) for blk-pos150 = (let ((tmp (mapcar #'cl-first blk-pos))) (if (cl-some #'zerop tmp) (list "*-*" "*-*" "*-*" "*-*") tmp)) for blk-pos168 = (let ((tmp (mapcar #'cl-second blk-pos))) (if (cl-some #'zerop tmp) (list "*-*" "*-*" "*-*" "*-*") tmp)) for blk-type = (mapcar (lambda (x) (elt bta (cl-third x))) blk-pos) collect (append blk-pos150 blk-pos168 blk-type))))))) (defun BWS-make-sheet-grid-table (sheet cell-function) (let ((snx (if (= sheet 150) 10 12)) (sny (if (= sheet 150) 15 14))) (concat "#+ATTR_HTML: :rules all solid #ccc :frame all :align center\n" (BWS-ltable-to-org-table-string (append (list (cl-loop for x from 0 upto snx collect "<c>")) (if (= sheet 150) (list (append (list "/150/") (cl-loop for x from 0 upto (1- snx) collect (format "*%02d*" (1+ x)))))) (cl-loop for y from 0 upto (1- sny) collect (append (if (= sheet 150) (list (format "*%02d*" (1+ y)))) (cl-loop for x from 0 upto (1- snx) for p = (+ 1 (* y snx) x) collect (funcall cell-function p)) (if (= sheet 168) (list (format "*%02d*" (1+ y)))))) (if (= sheet 168) (list (append (cl-loop for x from 0 upto (1- snx) collect (format "*%02d*" (1+ x))) (list "/168/")))))))))
2. Code Snippets
2.1. Burelage Types
2.1.1. The BWS-find-burelage-match Function
When faced with a block of stamps it is frequently possible to plate the block using the block's burelage types. Searching manually for matching blocks is tedious, and so I have a little lisp function for that:
(documentation 'BWS-find-burelage-match)
"Given a burelage pattern, produce a list of matches.
Each match is a list with three values: univeral position, position on 150, position on 168.
Example patterns:
- A block of four ......... ’((1 2)
(3 4))
- A horizontal stip of 5 .. ’((1 2 3 4 5))
- A vertical stip of 3 .... ’((1)
(2)
(3))
- An irregular block ...... ’((1 2 0)
(0 3 4))
Note the use of 0 as a wild card -- it effectively matches any type
- Ambiguous block ......... ’((13 2)
(3 4))
The use of 13 here indicates the upper left position may be a 1 OR 3. One might use 13 if
all they can tell about the background is that the ’triangle’ is at the top of the stamp.
In general, the individual digits are taken as allowable types to match. For example,
123 means to match 1, or 2, or 3."
2.1.2. Presenting results as a table
(concat "#+ATTR_HTML: :align center\n" "| Universal Position | 150 Position | 168 Position |\n" "|--------------------+--------------+--------------|\n" "| <c> | <c> | <c> |\n" ;; (BWS-ltable-to-org-table-string (BWS-ltable-stringafy (BWS-find-burelage-match '((24 0 13 13 13) ;; (13 0 24 24 13)))))) ;; (BWS-ltable-to-org-table-string (BWS-ltable-stringafy (BWS-find-burelage-match '((24 13 13 24 13) ;; (24 13 24 24 13) ;; (0 0 13 24 24)))))) (BWS-ltable-to-org-table-string (BWS-ltable-stringafy (BWS-find-burelage-match '((3 1) (0 1))))))
| Universal Position | 150 Position | 168 Position |
|---|---|---|
| 85 | 71 | 73 |
2.1.3. Presenting results as a sheet diagram
(let* ((pat '((24 13 24) (13 13 24) (13 13 24))) (locs (BWS-ltable-get-col (BWS-find-burelage-match pat) 0))) (BWS-make-burelage-table (lambda (p) (if (member p locs) "P" "W"))))
| 150 | 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | |||
| 1 | II |
IV |
IV |
IV |
I |
I |
IV |
I |
II |
III |
|||
| 2 | I |
IV |
IV |
II |
I |
I |
II |
IV |
III |
II |
II |
IV |
1 |
| 3 | III |
I |
I |
IV |
III |
I |
I |
IV |
III |
I |
III |
IV |
2 |
| 4 | III |
II |
III |
IV |
II |
II |
I |
IV |
I |
IV |
IV |
III |
3 |
| 5 | IV |
IV |
I |
I |
I |
II |
IV |
III |
II |
I |
II |
IV |
4 |
| 6 | I |
I |
I |
I |
II |
I |
I |
I |
II |
II |
I |
III |
5 |
| 7 | II |
I |
I |
IV |
II |
IV |
IV |
I |
I |
I |
IV |
IV |
6 |
| 8 | III |
I |
III |
III |
II |
IV |
I |
IV |
I |
III |
II |
IV |
7 |
| 9 | III |
I |
II |
IV |
I |
I |
III |
III |
IV |
IV |
I |
I |
8 |
| 10 | I |
II |
III |
III |
IV |
II |
IV |
I |
II |
III |
IV |
III |
9 |
| 11 | III |
I |
II |
III |
II |
III |
I |
I |
IV |
I |
IV |
III |
10 |
| 12 | III |
IV |
III |
II |
II |
III |
III |
III |
II |
II |
IV |
II |
11 |
| 13 | III |
III |
III |
II |
II |
IV |
III |
II |
II |
II |
II |
IV |
12 |
| 14 | IV |
IV |
III |
II |
I |
IV |
III |
IV |
IV |
II |
II |
IV |
13 |
| 15 | IV |
III |
III |
I |
III |
III |
IV |
IV |
IV |
III |
III |
IV |
14 |
| 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 168 |
2.2. Largest Inventory ID number by type
(concat "#+ATTR_HTML: :align center\n" "| Largest ID |\n" "|------------|\n" (BWS-ltable-to-org-table-string (cl-remove-duplicates (sort (BWS-ltable-get-col loc2id 1) #'string-lessp) :test #'BWS-ids-same-typep)))
| Largest ID |
|---|
| bwIDbh001 |
| bwIDdbl006 |
| bwIDdrkb003 |
| bwIDdrkw004 |
| bwIDesy002 |
| bwIDidbl003 |
| bwIDimp006 |
| bwIDimph008 |
| bwIDimps003 |
| bwIDimpv004 |
| bwIDmisbg006 |
| bwIDmisfg004 |
| bwIDovrc001 |
| bwIDp2s019 |
| bwIDpdue002 |
| bwIDpf008 |
| bwIDpfrk001 |
| bwIDps001 |
| bwIDqbu006 |
| bwIDqbw003 |
| bwIDrepb002 |
| bwIDruf004 |
| bwIDsamp010 |
| bwIDsgl078 |
| bwIDshade015 |
| bwIDsheetu001 |
| bwIDsheetw001 |
2.3. Number of items in each book
(apply #'concat
"#+ATTR_HTML: :align center\n"
"| Book | Count |\n"
"|------+-------|\n"
(let ((dat (BWS-ltable-get-col loc2id 0)))
(mapcar (lambda (book) (format "|%s|%d|\n" book (cl-count-if (lambda (x) (BWS-loc-same-book book x)) dat)))
(cl-remove-duplicates (mapcar (lambda (x) (substring x 0 1)) dat) :test #'string-equal))))
| Book | Count |
|---|---|
| C | 88 |
| S | 64 |