Day 12

aoc2024-eutro.el

@@ -44,6 +44,10 @@
 (defconst aoc--run-script (expand-file-name "run.sh" aoc-root))
 (defconst aoc--explore-script (expand-file-name "explore.sh" aoc-root))
 
+(defconst aoc--display-buffer-action nil
+  ;;'display-buffer-use-least-recent-window
+  )
+
 (defun aoc-run (&optional prefix)
   "Run the current day.
 
@@ -58,46 +62,90 @@ With PREFIX, read input from the buffer."
     (set-process-sentinel
      proc
      (lambda (_proc msg)
-       (with-selected-window (get-buffer-window buf)
+       (when-let ((win (get-buffer-window buf)))
-         (recenter -1))))
+         (with-selected-window win 
+           (recenter -1)))))
     (unless (eq (window-buffer win) buf)
       (if prefix
-          (pop-to-buffer buf 'display-buffer-use-least-recent-window)
+          (pop-to-buffer buf aoc--display-buffer-action)
-        (display-buffer buf 'display-buffer-use-least-recent-window)))
+        (display-buffer buf aoc--display-buffer-action)))
     (message "./run.sh %s" (string-join (mapcar #'shell-quote-argument args) " "))))
 
 (defun aoc-explore--filter (proc output)
   (with-current-buffer (process-buffer proc)
-    (insert output)))
+    (save-excursion
+      (goto-char (point-max))
+      (insert output))))
 
 (defun aoc-explore--sentinel (proc status)
-  (message status))
+  ;(message status)
+  nil)
 
-(defun aoc-explore (what)
+(defun aoc-explorer ()
-  "Start an interactive explorer on WHAT for the current day."
+  "Start an interactive explorer for the current day."
-  (interactive "MExplore: ")
+  (interactive)
   (let* ((day (aoc-day-number))
-         (args (list aoc--explore-script what (number-to-string day)))
+         (args (list aoc--explore-script (number-to-string day)))
          (buf (get-buffer-create "*aoc-explore*"))
          (proc (get-buffer-process buf)))
     (when (process-live-p proc)
-      (quit-process proc))
+      (process-send-eof proc))
     (with-current-buffer buf
       (erase-buffer)
       (setq aoc-pinned-day-number day)
-      (org-mode))
+      (org-mode)
+      (visual-line-mode))
     (setq proc
           (make-process
            :name "aoc-explore"
            :buffer buf
            :command args
+           :stderr (get-buffer-create "*aoc-explore error*")
            :filter #'aoc-explore--filter
            :sentinel #'aoc-explore--sentinel))
-    (pop-to-buffer buf 'display-buffer-use-least-recent-window)))
+    (pop-to-buffer buf aoc--display-buffer-action)
+    proc))
+
+(defun aoc-explorer--find ()
+  "Find or create the explorer process."
+  (if current-prefix-arg
+      (aoc-explorer)
+    (let (buf proc)
+      (setq buf (get-buffer "*aoc-explore*"))
+      (when buf (setq proc (get-buffer-process buf)))
+      (if (process-live-p proc)
+          (progn
+            (pop-to-buffer buf aoc--display-buffer-action)
+            proc)
+        (aoc-explorer)))))
+
+(defun aoc-explore-command (cmd)
+  "Clear the buffer and send the AoC explorer the specific command."
+  (interactive "MCommand: ")
+  (let ((proc (aoc-explorer--find))
+        (cmd (string-join (list (string-replace "\n" "" cmd) "\n"))))
+    (with-current-buffer (process-buffer proc)
+      (erase-buffer)
+      (process-send-string proc cmd))))
+
+(defun aoc-explore (what)
+  (interactive "MExplore: ")
+  (aoc-explore-command (format "explore %s" what)))
 
 (defun aoc-follow-link (path prefix)
   "Follow the AoC link PATH with universal PREFIX argument."
-  (aoc-explore link))
+  (message "Following: %s" path)
+  (aoc-explore-command (format "resolve %s" path)))
+
+(defun aoc-list-classes ()
+  "List all the classes."
+  (interactive)
+  (aoc-explore-command "list classes"))
+
+(defun aoc-list-selectors ()
+  "List all the selectors."
+  (interactive)
+  (aoc-explore-command "list selectors"))
 
 (with-eval-after-load 'ol
   (setf (alist-get "aoc2024eutro" org-link-parameters nil nil #'equal)

days/day09.st

@@ -5,7 +5,7 @@ Object subclass: DriveBase [
     idAt: i [^ids at: i]
 
     isEmpty: i [^(ids at: i ifAbsent: [1]) isNil]
-    isFull: i [^(ids at: i ifAbsent: [nil]) isNil not]
+    isFull: i [^(ids at: i ifAbsent: [nil]) notNil]
 
     addBlock: id length: len [ len timesRepeat: [ids add: id] ]
     addFreeLength: len [ len timesRepeat: [ids add: nil] ]
@@ -17,8 +17,7 @@ Object subclass: DriveBase [
       id := 0. toPut := id.
       diskMap do: [
           :c | len := c digitValue.
-          toPut
+          toPut ifNil: [self addFreeLength: len.
-              ifNil: [self addFreeLength: len.
                         id := id + 1.
                         toPut := id]
                 ifNotNil: [self addBlock: id length: len.
@@ -26,7 +25,7 @@ Object subclass: DriveBase [
       ids := ids asArray ]
 
     checksum
-    [ ^((1 to: self diskSize) collect:
+    [ ^(1 to: self diskSize collect:
           [ :i | (self idAt: i) ifNil: [0] ifNotNil: [:x | (i - 1) * x] ])
            sum ]
 
@@ -37,7 +36,7 @@ Object subclass: DriveBase [
       ^ids ]
 
     printOn: st
-    [ (1 to: self diskSize) do:
+    [ 1 to: self diskSize do:
         [ :i | (self idAt: i) ifNil: [st << '. '] ifNotNil: [:id | st << id << ' '] ] ]
 ]
 
@@ -119,11 +118,11 @@ DriveBase subclass: DriveP2 [
       super addFreeLength: len ]
 
     compact
-    [ (lastId to: 0 by: -1) do: [:id | self compactBlock: id].
+    [ lastId to: 0 by: -1 do: [:id | self compactBlock: id].
       self compress ]
 
     moveBlock: block to: free
-    [ (1 to: block len) do:
+    [ 1 to: block len do:
           [ :off |
             ids at: free pos + off put: (ids at: block pos + off).
             ids at: block pos + off put: nil.

days/day11.st

@@ -0,0 +1,39 @@
+Object subclass: RockSet [
+    | rocks | rocks [^rocks] rocks: n [rocks:=n asBag]
+
+    size [^rocks size]
+    blinkTimes: n [ n timesRepeat: [self blink] ]
+
+    blink
+    [ | oldRocks |
+      oldRocks := rocks.
+      rocks := Bag new.
+      oldRocks sortedByCount do: [
+          :it | self splitRock: it value multiplicity: it key ]]
+
+    addRock: num times: count
+    [ rocks add: num withOccurrences: count ]
+
+    splitRock: num multiplicity: count
+    [ | ndigits |
+      num = 0 ifTrue: [^self addRock: 1 times: count].
+      ndigits := (num + 1) ceilingLog: 10.
+      ndigits even ifTrue: [
+          | p10 |
+          p10 := 10 raisedTo: ndigits // 2.
+          self addRock: num // p10 times: count.
+          self addRock: num \\ p10 times: count.
+          ^nil ].
+      self addRock: num * 2024 times: count ]
+
+    printOn: st [st << rocks]
+]
+
+AOC input: [ RockSet new rocks:
+                 ((stdin nextLine tokenize: ' ')
+                      collect: [:it | it asNumber]) ];
+    part1: 25; part2: 50 "(cumulative)";
+    result: [ :rocks :blinks |
+              rocks blinkTimes: blinks.
+              rocks size. ];
+    finish.

days/day12.st

@@ -0,0 +1,103 @@
+Object subclass: UnionFind [
+    | root size |
+    initialize [ root := self. size := self initSize. ]
+    size [^size]
+    addSize: n [size := size + n]
+
+    initSize [^1]
+
+    find
+    [ ^root == self
+        ifTrue: [self]
+        ifFalse: [root := root find. root] ]
+
+    union: other
+    [ | myroot itroot |
+      myroot := self find. itroot := other find.
+      myroot == itroot ifTrue: [^myroot].
+      ^myroot mergeWith: itroot ]
+
+    mergeWith: other
+    [ | child parent |
+      size >= other size
+        ifTrue: [child := other. parent := self]
+        ifFalse: [parent := other. child := self].
+      child mergeInto: parent.
+      ^parent ]
+
+    mergeInto: parent
+    [ root := parent.
+      parent addSize: size.
+      size := 0 ]
+]
+
+UnionFind subclass: Region [
+    | regionSet perimeter corners |
+
+    initialize [super initialize. perimeter := 0. corners := 0.]
+    regionSet [^regionSet]
+    regionSet: n [regionSet:=n]
+
+    area [^size]
+    addPerimeter: n [perimeter := perimeter + n]
+    addCorners: n [corners := corners + n]
+
+    mergeInto: parent
+    [ super mergeInto: parent.
+      regionSet ifNotNil: [:it | it remove: self].
+      parent addCorners: corners.
+      parent addPerimeter: perimeter ]
+
+    fenceCost1 [^self area * perimeter]
+    fenceCost2 [^self area * corners]
+]
+
+Object subclass: GardenPlot [
+    | plantGrid regionGrid regionSet dirs dirsRot1 |
+
+    plants: g
+    [ dirs := {Posn up. Posn left. Posn down. Posn right}.
+      dirsRot1 := {Posn left. Posn down. Posn right. Posn up}.
+      plantGrid := g.
+      regionSet := Set new.
+      regionGrid := plantGrid collect: [
+          :ign | | reg |
+          reg := Region new regionSet: regionSet.
+          regionSet add: reg.
+          reg ].
+    ]
+
+    combineRegions [ plantGrid allPosnsDo: [:pos | self combineAt: pos] ]
+
+    combineAt: pos
+    [ | plant region |
+      plant := plantGrid at: pos.
+      region := regionGrid at: pos.
+      dirs with: dirsRot1 do: [
+          :off :off2 | | offPos oPlant same1 same2 same12 |
+          offPos := pos + off.
+          oPlant := plantGrid at: offPos.
+          same1 := oPlant = plant.
+          same2 := (plantGrid at: pos + off2) = plant.
+          same12 := (plantGrid at: pos + off + off2) = plant.
+
+          same1
+              ifTrue: [ region := region union: (regionGrid at: offPos) ]
+              ifFalse: [ region find addPerimeter: 1 ].
+
+          ((same1 not & same2 not "outer corner") |
+           (same1 & same2 & same12 not "inner corner"))
+              ifTrue: [ region find addCorners: 1 ]
+          ]
+    ]
+
+    totalFenceCost: block
+    [ ^regionSet inject: 0 into: [:acc :it | acc + (block value: it)] ]
+]
+
+AOC input: [ | plants | plants := Grid new rows: stdin toLines asArray.
+             GardenPlot new plants: plants; combineRegions ];
+    part1: [:it | it fenceCost1];
+    part2: [:it | it fenceCost2];
+    result: [ :plot :cost | plot totalFenceCost: cost ];
+    finish.

days/interaction.st

@@ -2,15 +2,16 @@ Object subclass: ExplorerStream [
     | stream objects | on: aStream
     [ stream := aStream. objects := OrderedCollection new. ]
 
+    at: idx [^objects at: idx ifAbsent: [nil]]
+
     title: title [ stream << '* ' << title; nl. ]
-    subtitle: block [ stream << '- '. block value. stream nl; nl. ]
+    subtitle: block [ stream << '- '. block value. stream nl. ]
     text: text [ text displayOn: stream ]
     nl [ stream nl ]
     flush [ stream flush ]
 
     linkTextTo: obj name: text
-    [ |r| r := '[[aoc2024eutro:objects/%2][%1]]' % {text . objects size}.
+    [ objects add: obj. ^'[[aoc2024eutro:objects/%2][%1]]' % {text . objects size} ]
-      objects add: obj. ^r ]
 
     linkTo: obj name: text [ self text: (self linkTextTo: obj name: text). ]
 
@@ -33,9 +34,57 @@ Object extend [
     emacsExploreMembersOn: exs []
 ]
 
-Class extend [
+Object subclass: MessageSource [
+    | name | name: n [name:=n] name [^name]
+
+    firstComment [ ^'No source available.' ]
+    category [ ^nil ]
+    argspec
+    [ | i | i := 0.
+      ^name asString copyReplacingAllRegex: ':' with: [
+               :ignored | i := i + 1. ': arg%1 ' % {i} ]]
+]
+MessageSource subclass: MessageSourcePresent [
+    | source |
+    source: n [source:=n]
+
+    quotedRegex: quote
+    [ ^('%1((?:[^%1]|%1%1)*?)%1(?!%1)' % {quote}) asRegex ]
+    unquoteString: str quote: quote
+    [ ^str copyReplacingAllRegex: '%1%1' % {quote}
+           with: '%1' % {quote} ]
+
+    findAndUnquote: pattern group: group quote: quote
+    [ ^(source searchRegex: pattern)
+           ifMatched: [ :m | self unquoteString: (m at: group) quote: quote ]
+           ifNotMatched: [ nil ] ]
+
+    firstComment
+    [ ^(self findAndUnquote: (self quotedRegex: $") group: 1 quote: $")
+           ifNotNil: [:cmt | cmt trimLines]]
+    category
+    [ | pat | pat := '<category: %1>' % {(self quotedRegex: $') asString}.
+      ^self findAndUnquote: pat group: 1 quote: $' ]
+
+    argspec
+    [ ^(source searchRegex: '\s*(.*?)\s*\[')
+           ifMatched: [:m | (m at: 1) copyReplacingAllRegex: '\s+' with: ' ']
+           ifNotMatched: [super argspec] ]
+]
+MessageSource class extend [
+    class: cls selector: name
+    [ ^(cls sourceCodeAt: name ifAbsent: [nil])
+           ifNil: [MessageSource new name: name]
+           ifNotNil: [
+               :source |
+               MessageSourcePresent new
+               name: name; source: source]]
+]
+
+ClassDescription extend [
     emacsExploreOn: exs
-    [ self basicEmacsExploreOn: exs.
+    [ | methods categories |
+      self basicEmacsExploreOn: exs.
       self superclass ifNotNil: [
           :sc | exs subtitle: [
               exs text: 'Superclass: ';
@@ -43,61 +92,141 @@ Class extend [
           ] ].
       self category ifNotNil: [
           :cat | exs subtitle: [ exs text: 'Category: '; text: cat ] ].
+      self emacsExploreMembersOn: exs.
+      exs nl.
+
       self comment
           ifNotNil: [ :cmnt | exs text: cmnt; nl; nl ]
           ifNil: [ exs text: 'No comment.'; nl; nl ].
 
       self subclasses size > 0 ifTrue: [
+          exs section: 'Class Hierarchy' do: [
                   exs subtitle: [
-          exs text: 'Subclasses: '.
+                      exs text: 'Direct Subclasses: '.
                       self subclasses
                           do: [ :sc | exs linkTo: sc name: sc ]
-              separatedBy: [ exs text: ', ' ]. ] ].
+                          separatedBy: [ exs text: ', ' ]].
+                  exs subtitle: [
+                      exs text: 'All Subclasses:'.
+                      self allSubclasses do: [
+                          :sc | exs nl; text: '  - '; linkTo: sc name: sc ]]].
+          exs nl.
+      ].
 
+      categories := Dictionary new.
+      methods := self selectors collect: [
+          :sel | MessageSource class: self selector: sel ].
+      methods do: [
+          :method | | cat | cat := method category ifNil: ['uncategorised'].
+          (categories at: cat ifAbsentPut: [
+                   SortedCollection sortBlock: [:l :r | l name <= r name]])
+              add: method ].
       exs section: 'Own members' do:
-          [ self selectors do: [
+          [ categories keysAndValuesDo: [
-              :selector | | method |
+              :cat :methods |
-              exs ssection: selector asString do:
+              exs ssection: cat do: [
-                  [ (self sourceCodeAt: selector ifAbsent: [nil])
+                  methods do: [
-                        ifNotNil: [
+                  :method |
-                      :source |
+                  exs subtitle: [
-                      exs
+                      exs text: '~%1~' % {method argspec}.
-                      text: '#+begin_src smalltalk'; nl;
+                      method firstComment ifNotNil: [
-                      text: source; nl;
+                          :cmt | exs nl; text: '  '; text: cmt]]
-                      text: '#+end_src'
+              ]]]]
-                  ]
-                        ifNil: [ exs text: 'No source available.' ] ]; nl; nl.
-          ] ]
     ]
 ]
 
-Object subclass: Explorer [
+Metaclass extend [
-    | what obj estream | what: n [what:=n]
+    emacsExploreMembersOn: exs
+    [ exs subtitle: [
+        exs text: 'Instance: ';
+            linkTo: self instanceClass
+            name: self instanceClass ] ]
+]
 
-    explore
+Object subclass: CommandHandler [
-    [ obj := Namespace current at: what ifAbsent: [nil].
+    | pattern block |
-      obj ifNil: [self reportNotFound]
+    pattern: n [pattern:=n]
-          ifNotNil: [self doExplore].
+    block: n [block:=n]
-      self exploreLoop ]
+    handleLine: line [ ^line scanf: pattern with: block ]
+]
+CommandHandler class extend [
+    handle: pattern with: block
+    [^CommandHandler new pattern: pattern; block: block]
+]
+
+Object subclass: Explorer [
+    | what obj estream handlers |
+
+    initialize
+    [ handlers :=
+      {CommandHandler handle: 'explore %s'
+                      with: [:it | self exploreName: it].
+       CommandHandler handle: 'resolve objects/%d'
+                      with: [:idx | self exploreIdx: idx].
+       CommandHandler handle: 'list classes' with: [self listClasses].
+       CommandHandler handle: 'list selectors' with: [self listSelectors]
+      } ]
+
+    explore [ self exploreLoop ]
 
     exploreLoop
     [ | line |
       [ stdin atEnd ] whileFalse: [
           line := stdin nextLine.
-          line printNl.
+          self handleLine: line ]]
-      ]]
 
-    reportNotFound
+    handleLine: line
-    [ stdout << what << ' is undefined.'; nl ]
+    [ handlers do: [:h | (h handleLine: line) ifNotNil: [^self]].
-    doExplore
+      stdout << ('Bad command: ''%1''' % {line}); nl; flush. ]
+
+    exploreName: what
+    [ obj := Smalltalk at: (Symbol intern: what) ifAbsent: [nil].
+      stderr << 'Exploring ' << what << '!'; nl; flush.
+      obj ifNil: [self reportNotFound: what]
+          ifNotNil: [self doExplore] ]
+    exploreIdx: idx
+    [ obj := estream at: idx.
+      stderr << 'Resolving ' << what << '!'; nl; flush.
+      self doExplore. ]
+
+    reportNotFound: what
+    [ stdout << what << ' is undefined.'; nl; flush ]
+
+    withStream: block
     [ estream := ExplorerStream on: stdout.
-      obj emacsExploreOn: estream.
+      block value.
-      estream flush.
+      estream flush ]
+
+    doExplore
+    [ self withStream: [obj emacsExploreOn: estream] ]
+
+    allClassesDo: block
+    [ Class allSubclassesDo: [:it | block value: it instanceClass] ]
+    listClasses
+    [ self withStream: [
+        self allClassesDo: [:class | estream linkTo: class name: class; nl]]]
+
+    listSelectors
+    [ | sels selsSorted |
+      sels := Dictionary new.
+      selsSorted := SortedCollection new.
+      self allClassesDo: [
+          :class | class selectors do: [
+              :sel |
+              (sels at: sel ifAbsentPut:
+                    [ SortedCollection sortBlock: [:l :r | l name <= r name]])
+              add: class
+          ]].
+      selsSorted addAll: sels keys.
+      self withStream: [
+          selsSorted do: [
+          :sel |
+          estream text: sel asString; text: ' -- '.
+          (sels at: sel) do: [:cls | estream linkTo: cls name: cls]
+                         separatedBy: [estream text: ', '].
+          estream nl.
+      ]]
     ]
 ]
 
-AOC action: 'explore' do:
+AOC action: 'explore' do: [ Explorer new explore ]
-    [ | what |
-      what := (Smalltalk getenv: 'AOC_WHAT') ifNil: ['Object'].
-      what := Symbol intern: what.
-      Explorer new what: what; explore ]

days/utils.st

@@ -157,7 +157,7 @@ Collection extend [
     [ ^(self size <= 0) ifTrue:
            [ #() ] ifFalse:
            [ | selfArr | selfArr := self asArray.
-             (1 to: (self at: 1) size) collect: [
+             1 to: (self at: 1) size collect: [
                  :i | selfArr collect: [ :elt | elt at: i ifAbsent: [nil] ] ] ] ]
 ]
 
@@ -176,6 +176,9 @@ Stream extend [
 String extend [
     scanf: fmt [ ^(ReadStream on: self) scanf: fmt ]
     scanf: fmt with: block [ ^(ReadStream on: self) scanf: fmt with: block ]
+
+    trim [ ^self copyReplacingRegex: '\s*(.*)\s*' asRegex with: [:m | m at: 1] ]
+    trimLines [ ^(self lines collect: [:it | it trim]) join: ' ' ]
 ]
 
 BlockClosure extend [
@@ -251,21 +254,29 @@ Object subclass: Grid [
     height [^rows size] width [^(rows at: 1) size]
 
     allPosnsDo: block
-    [ (1 to: self height) do:
+    [ 1 to: self height do:
-          [ :y | (1 to: self width) do:
+          [ :y | 1 to: self width do:
                [ :x | block value: (Posn x: x y: y) ] ] ]
     allPosnsOf: elt
     [ | oc | oc := OrderedCollection new.
       self allPosnsDo: [ :p | elt = (self at: p) ifTrue: [ oc add: p ] ].
       ^oc ]
 
+    collect: block
+    [ ^Grid width: self width height: self height initWith: [
+               :p | block value: (self at: p) ] ]
+
+    keysAndValuesCollect: block
+    [ ^Grid width: self width height: self height initWith: [
+               :p | block value: p value: (self at: p) ] ]
+
     printOn: st [ rows do: [ :r | st << r; nl ] ]
 ]
 Grid class extend [
     width: w height: h initWith: block
     [ | rows |
-      rows := (1 to: h) collect: [
+      rows := 1 to: h collect: [
-          :y | (1 to: h) collect: [
+          :y | 1 to: w collect: [
               :x | block value: (Posn x: x y: y)]].
       ^self new rows: rows ]
 ]

explore.sh

@@ -5,7 +5,5 @@ cd "$DIR" || exit 1
 
 export AOC_RUN='explore'
 export AOC_EXTRA_FILES="$AOC_EXTRA_FILES $DIR/days/interaction.st"
-export AOC_WHAT="$1"
-shift
 
 exec ./run.sh "$@" --

run.sh

@@ -29,4 +29,4 @@ if [ -z "$AOC_RUN" ] ; then
     AOC_RUN=1
 fi
 
-exec gst -g "days/utils.st" $AOC_EXTRA_FILES "days/day$DAYP.st" < "$AOC_INPUT"
+exec gst --emacs-mode -g "days/utils.st" $AOC_EXTRA_FILES "days/day$DAYP.st" < "$AOC_INPUT"