From 01a2490bc1f3e31d9c867dd3d2cd781eb0ecf548 Mon Sep 17 00:00:00 2001 From: eutro Date: Thu, 12 Dec 2024 12:13:20 +0000 Subject: [PATCH] Day 12 --- aoc2024-eutro.el | 76 +++++++++++++--- days/day09.st | 25 +++--- days/day11.st | 39 ++++++++ days/day12.st | 103 +++++++++++++++++++++ days/interaction.st | 213 +++++++++++++++++++++++++++++++++++--------- days/utils.st | 21 +++-- explore.sh | 2 - run.sh | 2 +- 8 files changed, 404 insertions(+), 77 deletions(-) create mode 100644 days/day11.st create mode 100644 days/day12.st diff --git a/aoc2024-eutro.el b/aoc2024-eutro.el index 2122693..3bebb72 100644 --- a/aoc2024-eutro.el +++ b/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) - (recenter -1)))) + (when-let ((win (get-buffer-window buf))) + (with-selected-window win + (recenter -1))))) (unless (eq (window-buffer win) buf) (if prefix - (pop-to-buffer buf 'display-buffer-use-least-recent-window) - (display-buffer buf 'display-buffer-use-least-recent-window))) + (pop-to-buffer buf aoc--display-buffer-action) + (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) - "Start an interactive explorer on WHAT for the current day." - (interactive "MExplore: ") +(defun aoc-explorer () + "Start an interactive explorer for the current day." + (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) diff --git a/days/day09.st b/days/day09.st index 5f03560..6668ad2 100644 --- a/days/day09.st +++ b/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,17 +17,16 @@ Object subclass: DriveBase [ id := 0. toPut := id. diskMap do: [ :c | len := c digitValue. - toPut - ifNil: [self addFreeLength: len. - id := id + 1. - toPut := id] - ifNotNil: [self addBlock: id length: len. - toPut := nil] ]. + toPut ifNil: [self addFreeLength: len. + id := id + 1. + toPut := id] + ifNotNil: [self addBlock: id length: len. + toPut := nil] ]. ids := ids asArray ] checksum - [ ^((1 to: self diskSize) collect: - [ :i | (self idAt: i) ifNil: [0] ifNotNil: [:x | (i - 1) * x] ]) + [ ^(1 to: self diskSize collect: + [ :i | (self idAt: i) ifNil: [0] ifNotNil: [:x | (i - 1) * x] ]) sum ] compress @@ -37,8 +36,8 @@ Object subclass: DriveBase [ ^ids ] printOn: st - [ (1 to: self diskSize) do: - [ :i | (self idAt: i) ifNil: [st << '. '] ifNotNil: [:id | st << id << ' '] ] ] + [ 1 to: self diskSize do: + [ :i | (self idAt: i) ifNil: [st << '. '] ifNotNil: [:id | st << id << ' '] ] ] ] DriveBase subclass: DriveP1 [ @@ -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. diff --git a/days/day11.st b/days/day11.st new file mode 100644 index 0000000..ad3314a --- /dev/null +++ b/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. diff --git a/days/day12.st b/days/day12.st new file mode 100644 index 0000000..486cefd --- /dev/null +++ b/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. diff --git a/days/interaction.st b/days/interaction.st index 4821bb8..fda2842 100644 --- a/days/interaction.st +++ b/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. ^r ] + [ objects add: obj. ^'[[aoc2024eutro:objects/%2][%1]]' % {text . objects size} ] 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 := '' % {(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 subtitle: [ - exs text: 'Subclasses: '. - self subclasses - do: [ :sc | exs linkTo: sc name: sc ] - separatedBy: [ exs text: ', ' ]. ] ]. + exs section: 'Class Hierarchy' do: [ + exs subtitle: [ + exs text: 'Direct Subclasses: '. + self subclasses + do: [ :sc | exs linkTo: sc name: sc ] + 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: [ - :selector | | method | - exs ssection: selector asString do: - [ (self sourceCodeAt: selector ifAbsent: [nil]) - ifNotNil: [ - :source | - exs - text: '#+begin_src smalltalk'; nl; - text: source; nl; - text: '#+end_src' - ] - ifNil: [ exs text: 'No source available.' ] ]; nl; nl. - ] ] + [ categories keysAndValuesDo: [ + :cat :methods | + exs ssection: cat do: [ + methods do: [ + :method | + exs subtitle: [ + exs text: '~%1~' % {method argspec}. + method firstComment ifNotNil: [ + :cmt | exs nl; text: ' '; text: cmt]] + ]]]] ] ] -Object subclass: Explorer [ - | what obj estream | what: n [what:=n] +Metaclass extend [ + emacsExploreMembersOn: exs + [ exs subtitle: [ + exs text: 'Instance: '; + linkTo: self instanceClass + name: self instanceClass ] ] +] - explore - [ obj := Namespace current at: what ifAbsent: [nil]. - obj ifNil: [self reportNotFound] - ifNotNil: [self doExplore]. - self exploreLoop ] +Object subclass: CommandHandler [ + | pattern block | + pattern: n [pattern:=n] + block: n [block:=n] + 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 - [ stdout << what << ' is undefined.'; nl ] - doExplore + handleLine: line + [ handlers do: [:h | (h handleLine: line) ifNotNil: [^self]]. + 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. - estream flush. + block value. + 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: - [ | what | - what := (Smalltalk getenv: 'AOC_WHAT') ifNil: ['Object']. - what := Symbol intern: what. - Explorer new what: what; explore ] +AOC action: 'explore' do: [ Explorer new explore ] diff --git a/days/utils.st b/days/utils.st index ff5a123..198e273 100644 --- a/days/utils.st +++ b/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: - [ :y | (1 to: self width) do: + [ 1 to: self height 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: [ - :y | (1 to: h) collect: [ + rows := 1 to: h collect: [ + :y | 1 to: w collect: [ :x | block value: (Posn x: x y: y)]]. ^self new rows: rows ] ] diff --git a/explore.sh b/explore.sh index 2789a43..37086c8 100755 --- a/explore.sh +++ b/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 "$@" -- diff --git a/run.sh b/run.sh index e99189a..94e408e 100755 --- a/run.sh +++ b/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"