Categories: geek » emacs » org

RSS - Atom - Subscribe via email

Using rubik.el to make SVG last-layer diagrams from algorithms

| cubing, emacs, org

So I checked out emacs-cube, but I had a hard time figuring out how to work with the data model without getting into all the rendering because it figures "left" and "right" based on camera position. rubik.el seemed like an easier starting point. As far as I can tell, the rubik-cube-state local variable is an array with the faces specified as 6 groups of 9 integers in this order: top, front, right, back, left, bottom, with cells specified from left to right, top to bottom.

First, I wanted to recolour rubik so that it matched the setup of the Roofpig JS library I'm using for animations. 

(defconst my-cubing-rubik-faces "YRGOBW")
;; make it match roofpig's default setup with yellow on top and red in front
(defconst rubik-faces [rubik-yellow
                       rubik-red
                       rubik-green
                       rubik-orange
                       rubik-blue
                       rubik-white])

Here are some functions to apply an algorithm (or actually, the inverse of the algorithm, which is useful for exploring a PLL case): 

(defun my-cubing-normalize (alg)
  "Remove parentheses and clean up spaces in ALG."
  (string-trim
   (replace-regexp-in-string "[() ]+" " " alg)))

(defun my-cubing-reverse-alg (alg)
  "Reverse the given ALG."
  (mapconcat
   (lambda (step)
     (if (string-match "\\`\\([rludfsbRLUDFSBxyz]\\)\\(['i]\\)?\\'" step)
         (concat (match-string 1 step)
                 (if (match-string 2 step)
                     ""
                   "'"))
       step))
   (reverse
    (split-string (my-cubing-normalize alg) " "))
   " "))

(defun my-cubing-rubik-alg (alg)
  "Apply the reversed ALG to a solved cube.
Return the rubik.el cube state."
  (let ((reversed (my-cubing-reverse-alg alg)))
    (seq-reduce
     (lambda (cube o)
       (when (intern (format "rubik-%s"
                             (replace-regexp-in-string "'" "i" o)))
         (unless (string= o "")
           (rubik-apply-transformation
            cube
            (symbol-value
             (intern
              (format "rubik-%s"
                      (replace-regexp-in-string "'" "i" o)))))))
       cube)
     (split-string reversed " ")
     (rubik-make-initial-cube))))

Then I got the strings specifying the side colours and the top colours in the format that I needed for the SVG diagrams. I'm optimistically using number-sequence here instead of hard-coding the numbers so that I can figure out how to extend the idea for 4x4 someday. 

(defun my-cubing-rubik-top-face-strings (&optional cube)
  ;; edges starting from back left
  (let ((cube (or cube rubik-cube-state)))
    (list
     (mapconcat
      (lambda (i)
        (char-to-string (elt my-cubing-rubik-faces (aref cube i))))
      (append
       (reverse (number-sequence (* 3 9) (+ 2 (* 3 9))))
       (reverse (number-sequence (* 2 9) (+ 2 (* 2 9))))
       (reverse (number-sequence (* 1 9) (+ 2 (* 1 9))))
       (reverse (number-sequence (* 4 9) (+ 2 (* 4 9))))))
     (mapconcat
      (lambda (i)
        (char-to-string (elt my-cubing-rubik-faces (aref cube i))))
      (number-sequence 0 8)))))

Then theoretically, it can make a diagram like this: 

(defun my-cubing-rubik-last-layer-with-sides-from-alg (alg &optional arrows)
  (apply 'my-cubing-last-layer-with-sides
         (append
          (my-cubing-rubik-top-face-strings (my-cubing-rubik-alg alg))
          (list
           arrows))))

So I can invoke it with: 

(my-cubing-rubik-last-layer-with-sides-from-alg
 "R U R' F' R U R' U' R' F R2 U' R' U'"
 '((1 7 t) (2 8 t)))
last-layer.svg

It's also nice to be able to interactively step through the algorithm. I prefer a more compact view of the undo/redo state. 

;; Override undo information
(defun rubik-display-undo ()
  "Insert undo information at point."
  (cl-loop with line-str = "\nUndo: "
           for cmd in (reverse (cdr rubik-cube-undo))
           for i = 1 then (1+ i)
           do (progn
                (setq line-str (concat line-str (format "%s " (get cmd 'name))))
                (when (> (length line-str) fill-column)
                  (insert line-str)
                  (setq line-str (concat "\n" (make-string 6 ?\s)))))
           finally (insert line-str)))

;; Override redo information
(defun rubik-display-redo ()
  "Insert redo information at point."
  (cl-loop with line-str = "\nRedo: "
           for cmd in (cdr rubik-cube-redo)
           for i = 1 then (1+ i)
           do (progn
                (setq line-str (concat line-str (format "%s " (get cmd 'name))))
                (when (> (length line-str) fill-column)
                  (insert line-str)
                  (setq line-str (concat "\n" (make-string 6 ?\s)))))
           finally (insert line-str)))
  
(defun my-cubing-convert-alg-to-rubik-commands (alg)
  (mapcar
   (lambda (step)
     (intern
      (format "rubik-%s-command"
              (replace-regexp-in-string "'" "i" step))))
   (split-string (my-cubing-normalize alg) " ")))

(rubik-define-commands
  rubik-U "U" rubik-U2 "U2" rubik-Ui "U'"
  rubik-F "F" rubik-F2 "F2" rubik-Fi "F'"
  rubik-R "R" rubik-R2 "R2" rubik-Ri "R'"
  rubik-L "L" rubik-L2 "L" rubik-Li "L'"
  rubik-B "B" rubik-B2 "B" rubik-Bi "B'"
  rubik-D "D" rubik-D2 "D" rubik-Di "D'"
  rubik-x "x" rubik-x2 "x" rubik-xi "x'"
  rubik-y "y" rubik-y2 "y" rubik-yi "y'"
  rubik-z "z" rubik-z2 "z2" rubik-zi "z'")

(defun my-cubing-rubik-set-to-alg (alg)
  (interactive "MAlg: ")
  (rubik)
  (fit-window-to-buffer)
  (setq rubik-cube-state (my-cubing-rubik-alg alg))
  (setq rubik-cube-redo (append (list 'redo)
                                (my-cubing-convert-alg-to-rubik-commands
                                 alg)))
  (setq rubik-cube-undo '(undo))
  (rubik-draw-all)
  (display-buffer (current-buffer)))

And now I can combine all those pieces together in a custom Org link type that will allow me to interactively step through an algorithm if I open it within Emacs and that will export to a diagram and an animation. 

(org-link-set-parameters
 "3x3"
 :follow #'my-cubing-rubik-open
 :export #'my-cubing-rubik-export)

(defun my-cubing-rubik-open (path &optional _)
  (my-cubing-rubik-set-to-alg (if (string-match "^\\(.*\\)\\?\\(.*\\)$" path)
                                  (match-string 1 path)
                                path))) 
  
(defun my-cubing-rubik-export (path _ format _)
  "Export PATH to FORMAT."
  (let (alg arrows params)
    (setq alg path)
    (when (string-match "^\\(.*\\)\\?\\(.*\\)$" path)
      (setq alg (match-string 1 path)
            params (org-protocol-convert-query-to-plist (match-string 2 path))
            arrows
            (mapcar (lambda (entry)
                      (mapcar 'string-to-number
                               (split-string entry "-"))) 
                    (split-string
                     (plist-get params :arrows) ","))))
    (concat
     (my-cubing-rubik-last-layer-with-sides-from-alg
      alg
      arrows)
     (format "<div class=\"roofpig\" data-config=\"base=PLL|alg=%s\"></div>"
             (my-cubing-normalize alg)))))

Let's try that with this F-perm, which I haven't memorized yet: 

[[3x3:(R' U' F')(R U R' U')(R' F R2 U')(R' U' R U)(R' U R)?arrows=1-7,7-1,2-8,8-2]]

At some point, I'd like to change the display for rubik.el so that it uses SVGs. (Or the OpenGL hacks in https://github.com/Jimx-/emacs-gl, but that might be beyond my current ability.) In the meantime, this might be fun.

In rubik.el, M-r redoes a move and M-u undoes it. Here's what it looks like with my tweaked interface:

output-2023-02-09-15:25:42.gif
Figure 1: Animated GIF of rubik.el stepping through an F-perm
View org source for this post
View or add comments (Disqus), or e-mail me at sacha@sachachua.com

Using Org Babel to learn Rubik's cube algorithms

| emacs, cubing, org

A+ has started learning Rubik's cube algorithms for permutation of the last layer (PLL) algorithms for the Rubik's cube. To help her focus on just a few at a time instead of getting distracted by the long list in the Cubeskills PLL PDF, I made a page that listed the algorithms that she was working on so that I could export it with ox-hugo to the mini-site I made for her interests.

She sometimes gets a little confused about clockwise and counter-clockwise, so I used Roofpig to add an animated view of the algorithm that she can step through. I wanted to make it easier for her to follow the algorithm without constantly moving her hands from the cube to the tablet or looking up and down all the time, but I didn't want to recompile the source just yet. I used the roofpig_and_three.min.js file and hacked speech synthesis into it by modifying the object prototype. For example, here's the Org source for adding a Jb perm: 

#+begin_export html
<div class="roofpig" data-config="base=PLL|alg=R U R' F' R U R' U' R' F R2 U' R' U'"></div>
#+end_export

and here's what it looks like. Might only look nice on my website, and I added speech synthesis so you may want to mute it if you need to be quiet.

Code for setting up Roofpig with speech synthesis
<!--  -*- mode: web -*- -->
<style>
 .roofpig { max-width: 400px; margin-bottom: 80px; }
 </style>
 <script>

  function waitToAddSpeech() {
    if (window.cubesSpeakMoves || !window.speechSynthesis) return;
    if (window.CubeAnimation) {
      window.cubesSpeakMoves = true;
        addSpeechToCubeAnimations();
      } else {
        setTimeout(setUpCubes, 300);
      }
  }
  
  function setUpCubes() {
    if (!document.querySelector('script.roofpig')) {
      var script = document.createElement('script');
      script.setAttribute('src', '/blog/2023/02/using-org-babel-to-learn-rubik-s-cube-algorithms/roofpig_and_three.min.js');
      script.classList.add('roofpig');
      document.head.appendChild(script);
      waitToAddSpeech();
    }
  }
  
  function addSpeechToCubeAnimations() {
   if (!window.CubeAnimation || !window.CubeAnimation['by_id'] || !window.CubeAnimation['by_id'][1]) return;
   var cachedFunc = Object.getPrototypeOf(CubeAnimation['by_id'][1].dom).alg_changed;
   Object.getPrototypeOf(CubeAnimation['by_id'][1].dom).alg_changed = function() {
     if (arguments[4].past.length > lastNoted.length) {
       let moves = arguments[4].past.split(' ');
       let lastMove = moves[moves.length - 1];
       // is it lower-case? speak lowercase explicitly
       if (lastMove.match(/[rludbf]/)) {
         lastMove = 'lower ' + lastMove;
       } else { // avoid awkward-sounding moves like "capital R"
         lastMove = lastMove.toLowerCase();
       }
       lastMove = lastMove.replace(/'/, ' prime');
      window.speechSynthesis.speak(new SpeechSynthesisUtterance(lastMove));
     } else {
       console.log('going backwards');
     }
     lastNoted = arguments[4].past;
     return cachedFunc.apply(this, arguments);
   }
 }
 ROOFPIG_CONF_F2L = "solved=U*|hover=none|colored=U-|flags=canvas,showalg|speed=1000";
 ROOFPIG_CONF_PLL = "solved=U-|hover=near|colored=U*|flags=canvas,showalg|speed=1000";
 var lastNoted = '';
window.addEventListener('load', setUpCubes);
</script>

I also wanted to include diagrams to make it easier for her to choose the right algorithm and position the cube the right way at the beginning, but I didn't want to fuss around with lots of screenshots and little files. It turns out you can define arrows in SVG pretty easily, so I wrote some Emacs Lisp functions to generate those types of diagrams. First I started with just the arrows. 

(my-cubing-last-layer-arrows '((2 8 t) (5 7 t)))
arrows.svg

For practising recognition, I wanted to also include the colors on top and on the sides: 

(my-cubing-last-layer-with-sides "OOGRROGGRBBB" "YYYYYYYYY" '((2 8 t) (5 7 t)))
colors.svg

Emacs Lisp functions for cubing diagrams
;; Start of cubing code
(defun my-cubing-pos (size n i)
  (list
   (* (/ size n) (% i n))
   (* (/ size n) (/ i n))))
  
(defun my-cubing-last-layer-arrows (arrows)
  "Draw ARROWS.
Arrows are defined as a list of lists of the form
((from to) (from to t) ...). Ex: '(my-cubing-last-layer-arrows '((3 1 t) (2 8 t)))
Cells are numbered from left to right, top to bottom, with the top left box being 0.
"
  (let* ((size 99)
         (n 3)
         (arrow-color "#000")
         (svg (svg-create size size)))
    (svg--append
     svg
     (dom-node
      'defs
      nil
      (dom-node
       'marker
       '((id . "arrowhead")
         (markerWidth . "10")
         (markerHeight . "7")
         (refX . "0")
         (refY . "3.5")
         (orient . "auto-start-reverse"))
       (dom-node
        'polygon
        `((fill . ,arrow-color)
          (points . "0 0, 4 3.5, 0 7")))
       )))
    (dotimes (i (* n n))
      (let ((pos (my-cubing-pos size n i)))
        (svg-rectangle
         svg
         (car pos)
         (cadr pos)
         (/ size n)
         (/ size n)
         :fill "#fff"
         :stroke-width 1
         :stroke "#666")))
    (dolist (arrow arrows)
      (let ((from (car arrow))
            (to (cadr arrow)))
        (apply 'svg-line
               (append
                (list svg)
                (mapcar (lambda (o) (+ o (/ size (* 2 n))))
                        (my-cubing-pos size n from))
                (mapcar (lambda (o) (+ o (/ size (* 2 n))))
                        (my-cubing-pos size n to))
                (list
                 :stroke-width 2
                 :stroke arrow-color
                 :marker-start (if (elt arrow 2) "url(#arrowhead)")
                 :marker-end "url(#arrowhead)")))))
    (with-temp-buffer
      (svg-print svg)
      (buffer-string))))

(defvar my-cubing-colors '((?R  . "#ff0000")
                           (?G  . "#00ff00")
                           (?B  . "#0000ff")
                           (?O  . "#ed7117")
                           (?Y  . "#ffff00")
                           (?W  . "#ffffff")
                           (?\? . "#666666")))

(defun my-cubing-last-layer-with-sides (sides top arrows)
  "Draw a diagram of the top of the cube.
The style is similar to https://www.cubeskills.com/uploads/pdf/tutorials/pll-algorithms.pdf .
SIDES is a string specifying colors going clockwise from the back-left side.
TOP is a string specifying colors going from left to right, top to bottom.
Arrows are defined as a list of lists of the form ((from to) (from to t) ...).
Cells are numbered from left to right, top to bottom, with the top left box being 0.
Ex: (my-cubing-last-layer-with-sides \"ORRBOOGGGRBB\" \"YYYYYYYYY\" '((3 1 t) (2 8 t)))
"
  (let* ((size 99)
         (n 3)
         (side-size 10)
         (cell-size (/ (- size (* 2 side-size)) n))
         (arrow-color "#000")
         (svg (svg-create size size)))
    (svg--append
     svg
     (dom-node
      'defs
      nil
      (dom-node
       'marker
       '((id . "arrowhead")
         (markerWidth . "10")
         (markerHeight . "7")
         (refX . "0")
         (refY . "3.5")
         (orient . "auto-start-reverse"))
       (dom-node
        'polygon
        `((fill . ,arrow-color)
          (points . "0 0, 4 3.5, 0 7"))))))
    ;; Draw the sides. It's a string of colors going clockwise from back left
    (when sides
      (dotimes (i (* n 4))
        (apply 'svg-rectangle
               (append
                (list svg)
                (pcase (/ i n)
                  (0 (list (+ (* (% i n) cell-size) side-size)
                           0
                           cell-size
                           side-size))
                  (1 (list (+ side-size (* n cell-size))
                           (+ (* (% i n) cell-size) side-size)
                           side-size
                           cell-size))
                  (2 (list (+ (* (- n (% i n) 1) cell-size) side-size)
                           (+ (* n cell-size) side-size)
                           cell-size
                           side-size))
                  (3 (list 0
                           (+ (* (- n (% i n) 1) cell-size) side-size)
                           side-size
                           cell-size)))
                (list
                 :stroke-width 1
                 :stroke "#666"
                 :fill (assoc-default (elt sides i)
                                      my-cubing-colors
                                      'eq
                                      (assoc-default ?\? my-cubing-colors)))))))
    ;; Draw the top face specified by a string of colors going from left to right, top to bottom
    (dotimes (i (* n n))
      (let ((pos (my-cubing-pos (* cell-size n) n i)))
        (svg-rectangle
         svg
         (+ side-size (car pos))
         (+ side-size (cadr pos))
         cell-size
         cell-size
         :fill (if top
                   (assoc-default (elt top i) my-cubing-colors
                                  'eq
                                  (assoc-default ?\? my-cubing-colors))
                 (assoc-default ?\? my-cubing-colors))
         :stroke-width 1
         :stroke "#666")))
    ;; Draw the arrows
    (dolist (arrow arrows)
      (let ((from (car arrow))
            (to (cadr arrow)))                  
        (apply 'svg-line
               (append
                (list svg)
                (mapcar (lambda (o) (+ side-size o (/ cell-size 2)))
                        (my-cubing-pos (* n cell-size) n from))
                (mapcar (lambda (o) (+ side-size o (/ cell-size 2)))
                        (my-cubing-pos (* n cell-size) n to))
                (list
                 :stroke-width 2
                 :stroke arrow-color
                 :opacity 0.5
                 :marker-start (if (elt arrow 2) "url(#arrowhead)")
                 :marker-end "url(#arrowhead)")))))
    (with-temp-buffer
      (svg-print svg)
      (buffer-string))))
;; end of cubing code

I'll probably need to tweak the arrows when we eventually get to the G perms, but we're still a long way off. And it would probably be pretty cool to be able to generate the colours by going backwards from the algorithm, maybe building on top of emacs-cube, so that I can write my own notes about recognizing the in-between steps and recovering from the typical mistakes we make. (That wasn't around the last time I wrote about Emacs and cubing. Thanks to Akib for making and sharing it!) I'm curious about this LaTeX approach, too, but that can wait for another day.

View org source for this post
View or add comments (Disqus), or e-mail me at sacha@sachachua.com

Adding a custom header argument to Org Mode source blocks and using that argument during export

| org, emacs

I sometimes want to put long source blocks in a <details><summary>...</summary>...</details> block when I export to HTML, so that they're tucked away in a collapsible block. I tried using https://github.com/alhassy/org-special-block-extras to define my own #+begin_my_details "summary text" ... #+end_my_details block, but source blocks inside my_details doesn't get fontlocked properly while in the Org file. I wanted to add a :summary attribute to the regular src blocks, and to change the HTML export to wrap the code in details if the summary was specified.

Code for adding a :summary argument and using it during export
(setq org-babel-exp-code-template "#+begin_src %lang%switches%flags :summary %summary\n%body\n#+end_src")
(defun my-org-html-src-block (src-block _contents info)
  (let* ((result (org-html-src-block src-block _contents info))
         (block-info
          (org-with-point-at (org-element-property :begin src-block)
            (org-babel-get-src-block-info)))         
         (summary (assoc-default :summary (elt block-info 2))))
    (if (member summary '("%summary" ""))
        result
      (format "<details><summary>%s</summary>%s</details>"
              summary
              result))))
(with-eval-after-load 'ox-html
  (map-put! 
   (org-export-backend-transcoders (org-export-get-backend 'html))
   'src-block 'my-org-html-src-block))

So now I can use it by specifying blocks like this: 

#+begin_src emacs-lisp :summary "Code for adding a :summary argument and using it during export"
;; code goes here
#+end_src

It took me a bit of digging around to figure this out. When I added the :summary attribute, org-babel-get-src-block-info found it when I was in the Org file, but by the time my-org-html-src-block was called, the block had been replaced with a copy that didn't have the header argument. I dug around using edebug's d command for displaying the backtrace, stepping through various functions. I found out that in the process for exporting source code blocks, org-babel-exp-code replaces the source block with the value of org-babel-exp-code-template, substituting certain values. Adding the summary flag to that and retrieving the summary information using org-babel-get-src-block-info worked. I originally used advice-add to override org-html-src-block, but I think I'll try replacing the transcoder.

Adding custom header arguments could be useful for different export-related tweaks (someone wanted to create an argument for highlighting certain lines but hadn't figured it out in that thread). If there's a more elegant way to do this, I'd love to find out!

This is part of my Emacs configuration.
View or add comments (Disqus), or e-mail me at sacha@sachachua.com

Moving my Org post subtree to the 11ty directory

| 11ty, org, emacs, blogging

I sometimes want to move the Org source for my blog posts to the same directory as the 11ty-exported HTML. This should make it easier to update and reexport blog posts in the future. The following code copies or moves the subtree to the 11ty export directory. 

(defun my-org-11ty-copy-subtree (&optional do-cut)
  "Copy the subtree for the current post to the 11ty export directory.
With prefix arg, move the subtree."
  (interactive (list current-prefix-arg))
  (let* ((file-properties
          (org-element-map
              (org-element-parse-buffer)
              'keyword
            (lambda (el)
              (list
               (org-element-property :key el)
               (org-element-property :value el)
               (buffer-substring-no-properties
                (org-element-property :begin el)
                (org-element-property :end el))))))
         (entry-properties (org-entry-properties))
         (filename (expand-file-name
                    "index.org"
                    (expand-file-name
                     (assoc-default "EXPORT_ELEVENTY_FILE_NAME" entry-properties) 
                     (car (assoc-default "ELEVENTY_BASE_DIR" file-properties))))))
    (unless (file-directory-p (file-name-directory filename))
      (make-directory (file-name-directory filename) t))
    ;; find the heading that sets the current EXPORT_ELEVENTY_FILE_NAME
    (goto-char
     (org-find-property "EXPORT_ELEVENTY_FILE_NAME" (org-entry-get-with-inheritance "EXPORT_ELEVENTY_FILE_NAME")))
    (org-copy-subtree 1 (if do-cut 'cut))
    (with-temp-file filename
      (org-mode)
      (insert (or
               (mapconcat (lambda (file-prop) (elt file-prop 2))
                          file-properties
                          "")
               "")
              "\n")
      (org-yank))
    (find-file filename)
    (goto-char (point-min))))

Then this adds a link to it: 

(defun my-org-export-filter-body-add-index-link (string backend info)
  (if (and
       (member backend '(11ty html))
       (plist-get info :file-name)
       (plist-get info :base-dir)
       (file-exists-p (expand-file-name
                       "index.org"
                       (expand-file-name
                        (plist-get info :file-name)
                        (plist-get info :base-dir)))))
      (concat string
              (format "<div><a href=\"%sindex.org\">View org source for this post</a></div>"
                      (plist-get info :permalink)))
    string))

(with-eval-after-load 'ox
  (add-to-list 'org-export-filter-body-functions #'my-org-export-filter-body-add-index-link))

Then I want to wrap the whole thing up in an export function: 

(defun my-org-11ty-export (&optional async subtreep visible-only body-only ext-plist)
  (let* ((info (org-11ty--get-info subtreep visible-only))
         (file (org-11ty--base-file-name subtreep visible-only)))
    (unless (string= (plist-get info :input-file)
                     (expand-file-name
                      "index.org"
                      (expand-file-name
                       (plist-get info :file-name)
                       (plist-get info :base-dir))))
      (save-window-excursion
        (my-org-11ty-copy-subtree)))
    (org-11ty-export-to-11tydata-and-html async subtreep visible-only body-only ext-plist)
    (my-org-11ty-find-file)))

Now to figure out how to override the export menu. Totally messy hack! 

(with-eval-after-load 'ox-11ty
  (map-put (caddr (org-export-backend-menu (org-export-get-backend '11ty)))
           ?o (list "To Org, JSON, HTML" 'my-org-11ty-export)))
View org source for this post
View or add comments (Disqus), or e-mail me at sacha@sachachua.com

Org Mode: Including portions of files between two regular expressions

| org, emacs

I'd like to refer to snippets of code, but lines are too fragile to use as references for code and posts that I want to easily update. I'd like to specify a from-regexp and a to-regexp instead in order to collect the lines between those regexps (including the ones with the regexps themselves). org-export-expand-include-keyword looked a bit hairy to extend since it uses regular expressions to match parameter values. For this quick experiment, I decided to make a custom link type instead. This allows me to refer to parts of code with a link like this:

[[my-include:~/proj/static-blog/assets/css/style.css::from-regexp=Start of copy code&to-regexp=End of copy code&wrap=src js]]

which will turn into this snippet from my stylesheet: 

/* Start of copy code */
pre.src { margin: 0 }
.org-src-container {
    position: relative;
    margin: 0 0;
    padding: 1.75rem 0 1.75rem 1rem;
}
summary { position: relative; }
summary .org-src-container { padding: 0 }
summary .org-src-container pre.src { margin: 0 }
.org-src-container button.copy-code, summary button.copy-code {
    position: absolute;
    top: 0px;
    right: 0px;
}
/* End of copy code */

Here's the Emacs Lisp code to do that. my-include-complete function reuses my-include-open to narrow to the file, and my-include-complete uses consult--line so that we can specify the prompt. 

(org-link-set-parameters
 "my-include"
 :follow #'my-include-open
 :export #'my-include-export
 :complete #'my-include-complete)

(defun my-include-open (path &optional _)
  "Narrow to the region specified in PATH."
  (let (params start end)
    (if (string-match "^\\(.*+?\\)::\\(.*+\\)" path)
        (setq params (save-match-data (org-protocol-convert-query-to-plist (match-string 2 path)))
              path (match-string 1 path)))
    (find-file path)
    (setq start
          (or
           (and
            (plist-get params :from-regexp)
            (progn
              (goto-char (point-min))
              (when (re-search-forward (url-unhex-string (plist-get params :from-regexp)))
                (line-beginning-position))))
           (progn
             (goto-char (point-min))
             (point))))
    (setq end
          (or
           (and
            (plist-get params :to-regexp)
            (progn
              (when (re-search-forward (url-unhex-string (plist-get params :to-regexp)))
                (line-end-position))))
           (progn
             (goto-char (point-max))
             (point))))
    (when (or (not (= start (point-min)))
              (not (= end (point-max))))
      (narrow-to-region start end))))
    
(defun my-include-export (path _ format _)
  "Export PATH to FORMAT using the specified wrap parameter."
  (let (params body start end)
    (when (string-match "^\\(.*+?\\)::\\(.*+\\)" path)
      (setq params (save-match-data (org-protocol-convert-query-to-plist (match-string 2 path)))))
    (save-window-excursion
      (my-include-open path)
      (setq body (buffer-substring (point-min) (point-max))))
    (with-temp-buffer
      (when (plist-get params :wrap)
        (let* ((wrap (plist-get params :wrap))
               block args)
          (when (string-match "\\<\\(\\S-+\\)\\( +.*\\)?" wrap)
            (setq block (match-string 1 wrap))
            (setq args (match-string 2 wrap)) 
            (setq body (format "#+BEGIN_%s%s\n%s\n#+END_%s\n"
                               block (or args "")
                               body
                               block)))))
      (insert body)
      (org-export-as format nil nil t))))

(defun my-include-complete ()
  "Include a section of a file from one line to another, specified with regexps."
  (interactive)
  (require 'consult)
  (let ((file (read-file-name "File: ")))
    (save-window-excursion
      (find-file file)
      (concat "my-include:"
              file
              "::from-regexp="
              (let ((curr-line (line-number-at-pos
                                (point)
                                consult-line-numbers-widen))
                    (prompt "From line: "))
                (goto-char (point-min))
                (consult--line
                 (or (consult--with-increased-gc
                      (consult--line-candidates
                       nil
                       curr-line))
                     (user-error "No lines"))
                 :curr-line curr-line
                 :prompt prompt)        
                (url-hexify-string
                 (regexp-quote (buffer-substring (line-beginning-position) (line-end-position)))))
              "&to-regexp="
              (let ((curr-line (line-number-at-pos
                                (point)
                                consult-line-numbers-widen))
                    (prompt "To line: "))
                (goto-char (point-min))
                (consult--line
                 (or (consult--with-increased-gc
                      (consult--line-candidates
                       nil
                       curr-line))
                     (user-error "No lines"))
                 :curr-line curr-line
                 :prompt prompt)        
                (url-hexify-string
                 (regexp-quote (buffer-substring (line-beginning-position) (line-end-position)))))
              "&wrap=src " (replace-regexp-in-string "-mode$" "" (symbol-name major-mode))))))
This is part of my Emacs configuration.
View or add comments (Disqus), or e-mail me at sacha@sachachua.com

EmacsConf backstage: Using TRAMP and timers to run two tracks semi-automatically

| emacs, emacsconf, org

In previous years, organizers streamed the video feeds for EmacsConf from their own computers to the Icecast server, which was a little challenging because of CPU load. A server shared by a volunteer had a 6-core Intel Xeon E5-2420 with 48 GB of RAM, which turned out to be enough horsepower to run OBS for both the general and development track for EmacsConf 2022. One of the advantages of this setup was that I could write some Emacs Lisp to automatically play recorded intros and talk videos at scheduled times, right from the large Org file that had all the conference details. I used SCHEDULED: properties to indicate when talks should play, and that was picked up by another function that took the Org entry properties and put them into a plist.

This function scheduled the timers:

emacsconf-stream-schedule-timers
(defun emacsconf-stream-schedule-timers (&optional info)
  "Schedule PLAYING for the rest of talks and CLOSED_Q for recorded talks."
  (interactive)
  (emacsconf-stream-cancel-all-timers)
  (setq info (emacsconf-prepare-for-display (emacsconf-filter-talks (or info (emacsconf-get-talk-info)))))
  (let ((now (current-time)))
    (mapc (lambda (talk)
            (when (and (time-less-p now (plist-get talk :start-time)))
              (emacsconf-stream-schedule-talk-status-change talk (plist-get talk :start-time) "PLAYING"
                                                            `(:title (concat "Starting " (plist-get talk :slug)))))
            (when (and
                   (plist-get talk :video-file)
                   (plist-get talk :qa-time)
                   (not (string-match "none" (or (plist-get talk :q-and-a) "none")))
                   (null (plist-get talk :stream-files)) ;; can't tell when this is
                   (time-less-p now (plist-get talk :qa-time)))
              (emacsconf-stream-schedule-talk-status-change talk (plist-get talk :qa-time) "CLOSED_Q"
                                                            `(:title (concat "Q&A for " (plist-get talk :slug) " (" (plist-get talk :q-and-a) ")"))))
            )
          info)))

It turns out that TRAMP doesn't like being called from timers if there's a chance that two TRAMP processes might run at the same time. I got "Forbidden reentrant call of Tramp" errors when that happened. There was an easy fix, though. I adjusted the schedules of the talks so that they started at least a minute apart.

Sometimes I wanted to cancel just one timer:

emacsconf-stream-cancel-timer
(defun emacsconf-stream-cancel-timer (id)
  "Cancel a timer by ID."
  (interactive (list
                (completing-read
                 "ID: "
                 (lambda (string pred action)
                    (if (eq action 'metadata)
                        `(metadata (display-sort-function . ,#'identity))
                      (complete-with-action action
                                            (sort
                                             (seq-filter (lambda (o)
                                                           (and (timerp (cdr o))
                                                                (not (timer--triggered (cdr o)))))
                                                         emacsconf-stream-timers)
                                             (lambda (a b) (string< (car a) (car b))))
                                            string pred))))))
  (when (timerp (assoc-default id emacsconf-stream-timers))
    (cancel-timer (assoc-default id emacsconf-stream-timers))
    (setq emacsconf-stream-timers
          (delq (assoc id emacsconf-stream-timers)
                (seq-filter (lambda (o)
                              (and (timerp (cdr o))
                                   (not (timer--triggered (cdr o)))))
                            emacsconf-stream-timers)))))

and schedule just one timer manually:

emacsconf-stream-schedule-talk-status-change
(defun emacsconf-stream-schedule-talk-status-change (talk time new-status &optional notification)
  "Schedule a one-off timer for TALK at TIME to set it to NEW-STATUS."
  (interactive (list (emacsconf-complete-talk-info)
                     (read-string "Time: ")
                     (completing-read "Status: " (mapcar 'car emacsconf-status-types))))
  (require 'diary-lib)
  (setq talk (emacsconf-resolve-talk talk))
  (let* ((converted
          (cond
           ((listp time) time)
           ((timer-duration time) (timer-relative-time nil (timer-duration time)))
           (t                           ; HH:MM
            (date-to-time (concat (format-time-string "%Y-%m-%d" nil emacsconf-timezone)
                                  "T"
                                  (string-pad time 5 ?0 t) 
                                  emacsconf-timezone-offset)))))
         (timer-id (concat (format-time-string "%m-%dT%H:%M" converted)
                           "-"
                           (plist-get talk :slug)
                           "-"
                           new-status)))
    (emacsconf-stream-cancel-timer timer-id) 
    (add-to-list 'emacsconf-stream-timers
                  (cons
                   timer-id
                   (run-at-time time converted #'emacsconf-stream-update-talk-status-from-timer
                                talk new-status
                                notification)))))

The actual playing of talks happened using functions that were called from org-after-todo-state-change-hook. I wrote a function that extracted the talk information and then called my own list of functions.

emacsconf-org-after-todo-state-change
(defun emacsconf-org-after-todo-state-change ()
  "Run all the hooks in `emacsconf-todo-hooks'.
If an `emacsconf-todo-hooks' entry is a list, run it only for the
tracks with the ID in the cdr of that list."
  (let* ((talk (emacsconf-get-talk-info-for-subtree))
         (track (emacsconf-get-track (plist-get talk :track))))
    (mapc
     (lambda (hook-entry)
       (cond
        ((symbolp hook-entry) (funcall hook-entry talk))
        ((member (plist-get track :id) (cdr hook-entry))
         (funcall (car hook-entry) talk))))
     emacsconf-todo-hooks)))

For example, this function played the recorded intro and the talk:

emacsconf-stream-play-talk-on-change
(defun emacsconf-stream-play-talk-on-change (talk)
  "Play the talk."
  (interactive (list (emacsconf-complete-talk-info)))
  (setq talk (emacsconf-resolve-talk talk))
  (when (or (not (boundp 'org-state)) (string= org-state "PLAYING"))
    (if (plist-get talk :stream-files)
        (progn
          (emacsconf-stream-track-ssh
           talk
           "overlay"
           (plist-get talk :slug))
          (emacsconf-stream-track-ssh
           talk
           (append
            (list
             "nohup"
             "mpv")
            (split-string-and-unquote (plist-get talk :stream-files))
            (list "&"))))
      (emacsconf-stream-track-ssh
       talk
       (cons
        "nohup"
        (cond
         ((and
           (plist-get talk :recorded-intro)
           (plist-get talk :video-file)) ;; recorded intro and recorded talk
          (message "should automatically play intro and recording")
          (list "play-with-intro" (plist-get talk :slug))) ;; todo deal with stream files
         ((and
           (plist-get talk :recorded-intro)
           (null (plist-get talk :video-file))) ;; recorded intro and live talk; play the intro and join BBB
          (message "should automatically play intro; join %s" (plist-get talk :bbb-backstage))
          (list "intro" (plist-get talk :slug)))
         ((and
           (null (plist-get talk :recorded-intro))
           (plist-get talk :video-file)) ;; live intro and recorded talk, show slide and use Mumble; manually play talk
          (message "should show intro slide; play %s afterwards" (plist-get talk :slug))
          (list "intro" (plist-get talk :slug)))
         ((and
           (null (plist-get talk :recorded-intro))
           (null (plist-get talk :video-file))) ;; live intro and live talk, join the BBB
          (message "join %s for live intro and talk" (plist-get talk :bbb-backstage))
          (list "bbb" (plist-get talk :slug)))))))))

and this function handled IRC announcements when the talk state changed:

emacsconf-erc-announce-on-change
(defun emacsconf-erc-announce-on-change (talk)
  "Announce talk."
  (let ((func
         (pcase org-state
           ("PLAYING" #'erc-cmd-NOWPLAYING)
           ("CLOSED_Q" #'erc-cmd-NOWCLOSEDQ)
           ("OPEN_Q" #'erc-cmd-NOWOPENQ)
           ("UNSTREAMED_Q" #'erc-cmd-NOWUNSTREAMEDQ)
           ("TO_ARCHIVE" #'erc-cmd-NOWDONE))))
    (when func
      (funcall func talk))))

The actual announcements were handled by something like this:

erc-cmd-NOWCLOSEDQ
(defun erc-cmd-NOWCLOSEDQ (talk)
  "Announce TALK has started Q&A, but the host has not yet opened it up."
  (interactive (list (emacsconf-complete-talk-info)))
  (when (stringp talk) (setq talk (or (emacsconf-find-talk-info talk) (error "Could not find talk %s" talk))))
  (if (emacsconf-erc-recently-announced (format "-- Q&A beginning for \"%s\"" (plist-get talk :slug)))
      (message "Recently announced, skipping")
    (emacsconf-erc-with-channels (list (concat "#" (plist-get talk :channel)))
      (erc-send-message (format "-- Q&A beginning for \"%s\" (%s) Watch: %s Add notes/questions: %s"
                                (plist-get talk :title)
                                (plist-get talk :qa-info)
                                (plist-get talk :watch-url)
                                (plist-get talk :pad-url))))  
    (emacsconf-erc-with-channels (list emacsconf-erc-hallway emacsconf-erc-org)
      (erc-send-message (format "-- Q&A beginning for \"%s\" in the %s track (%s) Watch: %s Add notes/questions: %s . Chat: #%s"
                                (plist-get talk :title)
                                (plist-get talk :track)
                                (plist-get talk :qa-info)
                                (plist-get talk :watch-url)
                                (plist-get talk :pad-url)
                                (plist-get talk :channel))))))

All that code meant that during the actual conference, my role was mostly just worrying, and occasionally starting up the Q&A (if I wasn't sure if the code would do it right). The shell scripts I wrote made it easy for the other organizers to take over the second part as they saw how it worked.

Yay timers, Emacs, and TRAMP!

You can find the latest versions of these functions in the emacsconf-el repository.

View or add comments (Disqus), or e-mail me at sacha@sachachua.com

Comparison-shopping with Org Mode

| emacs, org

I don't like shopping. We're lucky to be able to choose, but I get overwhelmed with all the choices. I'm trying to get the hang of it, though, since I'll need to shop for lots of things for A- over the years. One of the things that's stressful is comparing choices between different webpages, especially if I want to get A-'s opinion on something. Between the challenge of remembering things as we flip between pages and the temptations of other products she sees along the way… Ugh.

I think there are web browser extensions for shopping, but I prefer to work within Org Mode so that I can capture links from my phone's web browser, refile entries into different categories, organize them with keyboard shortcuts, and tweak things the way I like. So if I have subheadings with the NAME, PRICE, IMAGE, and URL properties, I can make a table that looks like this:

2022-12-26_11-26-35.png

Figure 1: Comparison-shopping

using code that looks like this: 

#+begin_src emacs-lisp :eval yes :exports results :wrap EXPORT html
(my-org-format-shopping-subtree)
#+end_src

and I can view the table by exporting the subtree with HTML using org-export-dispatch (C-c C-e C-s h o). When I add new items, I can use C-u C-c C-e to reexport the subtree without navigating up to the root.

Here's the very rough code I use for that: 

(defun my-get-shopping-details ()
  (goto-char (point-min))
  (let (data)
    (cond
     ((re-search-forward "  data-section-data
>" nil t)
      (setq data (json-read))
      (let-alist data
        (list (cons 'name .product.title)
              (cons 'brand .product.vendor)
              (cons 'description .product.description)
              (cons 'image (concat "https:" .product.featured_image))
              (cons 'price (/ .product.price 100.0)))))
     ((and (re-search-forward "<script type=\"application/ld\\+json\">" nil t)
           (null (re-search-forward "Fabric Fabric" nil t))) ; Carter's, Columbia?
      (setq data (json-read))
      (if (vectorp data) (setq data (elt data 0)))
      (if (assoc-default '@graph data)
          (setq data (assoc-default '@graph data)))
      (if (vectorp data) (setq data (elt data 0)))
      (let-alist data
        (list (cons 'name .name)
              (cons 'url (or .url .@id))
              (cons 'brand .brand.name)
              (cons 'description .description)
              (cons 'rating .aggregateRating.ratingValue)
              (cons 'ratingCount .aggregateRating.reviewCount)
              (cons 'image (if (stringp .image) .image (elt .image 0)))
              (cons 'price
                    (assoc-default 'price (if (arrayp .offers)
                                              (elt .offers 0)
                                            .offers))))))
     ((re-search-forward "amazon.ca" nil t)
      (goto-char (point-min))
      (re-search-forward "^$")
      (let ((doc (libxml-parse-html-region (point) (point-max))))
        (list (cons 'name (dom-text (dom-by-tag doc 'title)))
              (cons 'description (dom-texts (dom-by-id doc "productDescription")))
              (cons 'image (dom-attr (dom-by-tag (dom-by-id doc "imgTagWrapperId") 'img) 'src))
              (cons 'price
                    (dom-texts (dom-by-id doc "priceblock_ourprice"))))))
     (t
      (goto-char (point-min))
      (re-search-forward "^$")
      (let* ((doc (libxml-parse-html-region (point) (point-max)))
             (result
              `((name . ,(string-trim (dom-text (dom-by-tag doc "title"))))
                (description . ,(string-trim (dom-text (dom-by-tag doc "title")))))
              ))
        (mapc (lambda (property)
                (let ((node
                       (dom-search
                        doc
                        (lambda (o)
                          (delq nil
                                (mapcar (lambda (p)
                                          (or (string= (dom-attr o 'property) p)
                                              (string-match p (or (dom-attr o 'class) ""))))
                                        (cdr property)))))))
                  (when node (add-to-list 'result (cons (car property)
                                                        (or (dom-attr node 'content)
                                                            (string-trim (dom-text node))))))))
              '((name "og:title" "pdp-product-title")
                (brand "og:brand")
                (url "og:url")
                (image "og:image")
                (description "og:description")
                (price "og:price:amount" "product:price:amount" "pdp-price-label")))
        result)
      ))))
(defun my-org-insert-shopping-details ()
  (interactive)
  (org-insert-heading)
  (save-excursion (yank))
  (my-org-update-shopping-details)
  (when (org-entry-get (point) "NAME")
    (org-edit-headline (org-entry-get (point) "NAME")))
  (org-end-of-subtree))
(defun my-org-update-shopping-details ()
  (interactive)
  (when (re-search-forward org-link-any-re (save-excursion (org-end-of-subtree)) t)
    (let* ((link (org-element-property :raw-link (org-element-context)))
           data)
      (if (string-match "theshoecompany\\|dsw" link)
          (progn
            (browse-url link)
            (org-entry-put (point) "URL" link)
            (unless (org-entry-get (point) "IMAGE")
              (org-entry-put (point) "IMAGE" (read-string "Image: ")))
            (unless (org-entry-get (point) "PRICE")
              (org-entry-put (point) "PRICE" (read-string "Price: "))))
        (setq data (with-current-buffer (url-retrieve-synchronously link)
                     (my-get-shopping-details)))
        (when data
          (let-alist data
            (org-entry-put (point) "NAME" .name)
            (org-entry-put (point) "URL" link)
            (org-entry-put (point) "BRAND" .brand)
            (org-entry-put (point) "DESCRIPTION" (replace-regexp-in-string "&#039;" "'" (replace-regexp-in-string "\n" " " (or .description ""))))
            (org-entry-put (point) "IMAGE" .image)
            (org-entry-put (point) "PRICE" (cond ((stringp .price) .price) ((numberp .price) (format "%.2f" .price)) (t ""))) 
            (if .rating (org-entry-put (point) "RATING" (if (stringp .rating) .rating (format "%.1f" .rating))))
            (if .ratingCount (org-entry-put (point) "RATING_COUNT" (if (stringp .ratingCount) .ratingCount (number-to-string .ratingCount))))
            ))))))
(defun my-org-format-shopping-subtree ()
  (concat
   "<style>body { max-width: 100% !important } #content { max-width: 100% !important } .item img { max-height: 100px; }</style><div style=\"display: flex; flex-wrap: wrap; align-items: flex-start\">"
   (string-join
    (save-excursion
      (org-map-entries
       (lambda ()
         (if (org-entry-get (point) "URL")
             (format
              "<div class=item style=\"width: 200px\"><div><a href=\"%s\"><img src=\"%s\" height=100></a></div>
<div>%s</div>
<div><a href=\"%s\">%s</a></div>
<div>%s</div>
<div>%s</div></div>"
              (org-entry-get (point) "URL")
              (org-entry-get (point) "IMAGE")
              (org-entry-get (point) "PRICE")
              (org-entry-get (point) "URL")
              (url-domain (url-generic-parse-url (org-entry-get (point) "URL")))
              (org-entry-get (point) "NAME")
              (or (org-entry-get (point) "NOTES") ""))
           ""))
       nil
       (if (org-before-first-heading-p) nil 'tree)))
    "")
   "</div>"))

At some point, it would be nice to keep track of how I feel about different return policies, and to add more rules for automatically extracting information from different websites. (org-chef might be a good model.) In the meantime, this makes it a little less stressful to look for stuff.

This is part of my Emacs configuration.
View or add comments (Disqus), or e-mail me at sacha@sachachua.com