Skip to content

Commit

Permalink
Added LEAST. Refactored MOST.
Browse files Browse the repository at this point in the history
  • Loading branch information
@dsletten
dsletten committed Oct 1, 2024
1 parent d02626d commit a18a1a9
Show file tree
Hide file tree
Showing 2 changed files with 112 additions and 123 deletions.
149 changes: 52 additions & 97 deletions core.lisp
View file
Original file line number Diff line number Diff line change
Expand Up @@ -42,7 +42,7 @@
:get-num :group :group-until :horners
:if-let :if3 :iffn :in :in-if :inq :is-integer :iterate
:juxtapose
:last1 :list-to-string :longerp
:last1 :least :leastn :list-to-string :longerp
:macroexpand-all :make-empty-seq :make-identity-matrix :make-range
:map-> :map-array :map-array-index :map0-n :map1-n :mapa-b :mapcars :mappend :mapset
:memoize :mklist :mkstr :most :mostn :most-least :most-least-n :nif
Expand Down Expand Up @@ -1293,49 +1293,10 @@ starting with X or the index of the position of X in the sequence."))
(position obj seq :start (1+ initial) :test test :key key))))

;; (defun most-concept (f seq)
;; (let ((sorted (stable-sort (map 'vector #'(lambda (elt) (list elt (funcall f elt))) seq) #'> :key #'second)))
;; (let* ((scores (map 'vector #'(lambda (elt) (list elt (funcall f elt))) seq))
;; (sorted (stable-sort scores #'> :key #'second)))
;; (values-list (aref sorted 0))))

;; (defun most (fn list)
;; (if (null list)
;; (values nil nil)
;; (let* ((wins (car list))
;; (max (funcall fn wins)))
;; (dolist (obj (cdr list))
;; (let ((score (funcall fn obj)))
;; (when (> score max)
;; (setq wins obj
;; max score))))
;; (values wins max))))

;; ;;;
;; ;;; This works, but it CONSes a lot!
;; ;;;
;; (defun most (f seq)
;; "Locate the first element in SEQ that yields the highest value when F is applied. The secondary value is the value returned by F for that element."
;; (let ((first (elt seq 0)))
;; (values-list (reduce #'(lambda (winner elt)
;; (let ((score (funcall f elt)))
;; (if (> score (second winner))
;; (list elt score)
;; winner)))
;; seq
;; :initial-value (list first (funcall f first)))) ))

;; ;;;
;; ;;; Not totally FP!!
;; ;;;
;; (defun most (f seq)
;; "Locate the first element in SEQ that yields the highest value when F is applied. The secondary value is the value returned by F for that element."
;; (let* ((winner (elt seq 0))
;; (max (reduce #'(lambda (max elt)
;; (let ((score (funcall f elt)))
;; (cond ((> score max) (setf winner elt) score)
;; (t max))))
;; seq
;; :initial-value (funcall f winner))))
;; (values winner max)))

;; (defun most (f seq)
;; (labels ((most-list (seq winner max)
;; (if (endp seq)
Expand All @@ -1362,40 +1323,31 @@ starting with X or the index of the position of X in the sequence."))
;; (most-vector 1 (elt seq 0) (funcall f (elt seq 0)))) ))))

(defun most (f seq)
"Locate the first element in SEQ that yields the highest value when F is applied. The secondary value is the value returned by F for that element."
(extremum f #'> seq))
(defun least (f seq)
(extremum f #'< seq))

(defgeneric extremum (f order seq)
(:documentation "Locate the first element in SEQ that yields the extreme (in terms of ORDER) value when F is applied. The secondary value is the value returned by F for that element."))
(defmethod extremum :around (f order seq)
(if (emptyp seq)
(values nil nil)
(typecase seq
(list (loop with winner = (first seq)
with max = (funcall f winner)
for elt in (rest seq)
for score = (funcall f elt)
when (> score max) do (setf winner elt max score)
finally (return (values winner max))))
(vector (loop with winner = (elt seq 0)
with max = (funcall f winner)
for i from 1 below (length seq)
for elt = (elt seq i)
for score = (funcall f elt)
when (> score max) do (setf winner elt max score)
finally (return (values winner max)))) )))

;;;
;;; These are nice but they don't handle capturing the element itself...
;;;
;; (defun most (f seq)
;; (reduce #'(lambda (winner elt)
;; (let ((score (funcall f elt)))
;; (if (> score winner)
;; score
;; winner)))
;; seq
;; :initial-value (funcall f (elt seq 0))))

;; (defun most (f seq)
;; (typecase seq
;; (list (loop for elt in seq maximize (funcall f elt)))
;; (vector (loop for elt across seq maximize (funcall f elt)))) )
(call-next-method)))
(defmethod extremum (f order (seq list))
(loop with winner = (first seq)
with max = (funcall f winner)
for elt in (rest seq)
for score = (funcall f elt)
when (funcall order score max) do (setf winner elt max score)
finally (return (values winner max))))
(defmethod extremum (f order (seq vector))
(loop with winner = (elt seq 0)
with max = (funcall f winner)
for i from 1 below (length seq)
for elt = (elt seq i)
for score = (funcall f elt)
when (funcall order score max) do (setf winner elt max score)
finally (return (values winner max))))

;;;
;;; Compare MOST
Expand Down Expand Up @@ -1427,30 +1379,33 @@ starting with X or the index of the position of X in the sequence."))
;; (let ((starter (funcall f (elt seq 0))))
;; (most-least-vector 1 (elt seq 0) starter (elt seq 0) starter)))) )))

(defun most-least (f seq)
"Locate the first elements in SEQ that yield the highest/lowest value when F is applied. The values returned by F for those elements are also returned."
(defgeneric most-least (f seq)
(:documentation "Locate the first elements in SEQ that yield the highest/lowest value when F is applied. The values returned by F for those elements are also returned."))
(defmethod most-least :around (f seq)
(if (emptyp seq)
nil
(typecase seq
(list (loop with winner = (first seq)
with loser = winner
with max = (funcall f winner)
with min = max
for elt in (rest seq)
for score = (funcall f elt)
when (> score max) do (setf winner elt max score)
else when (< score min) do (setf loser elt min score)
finally (return (values winner max loser min))))
(vector (loop with winner = (elt seq 0)
with loser = winner
with max = (funcall f winner)
with min = max
for i from 1 below (length seq)
for elt = (elt seq i)
for score = (funcall f elt)
when (> score max) do (setf winner elt max score)
else when (< score min) do (setf loser elt min score)
finally (return (values winner max loser min)))) )))
(values nil nil nil nil)
(call-next-method)))
(defmethod most-least (f (seq list))
(loop with winner = (first seq)
with loser = winner
with max = (funcall f winner)
with min = max
for elt in (rest seq)
for score = (funcall f elt)
when (> score max) do (setf winner elt max score)
else when (< score min) do (setf loser elt min score)
finally (return (values winner max loser min))))
(defmethod most-least (f (seq vector))
(loop with winner = (elt seq 0)
with loser = winner
with max = (funcall f winner)
with min = max
for i from 1 below (length seq)
for elt = (elt seq i)
for score = (funcall f elt)
when (> score max) do (setf winner elt max score)
else when (< score min) do (setf loser elt min score)
finally (return (values winner max loser min))))

;; (defun best-concept (f seq)
;; (let ((sorted (stable-sort (copy-seq seq) f)))
Expand Down
86 changes: 60 additions & 26 deletions test-core.lisp
View file
Original file line number Diff line number Diff line change
Expand Up @@ -714,35 +714,69 @@

(deftest test-most ()
(check
(equal (multiple-value-list (most #'length '((a) (b) (c) (d)))) '((A) 1))
(equal (multiple-value-list (most #'length '((a b) (a b c) (a) (e f g)))) '((A B C) 3))
(equal (multiple-value-list (most #'length '())) '(() ()))
(equal (multiple-value-list (most #'length '((a b)))) '((A B) 2))
(equal (multiple-value-list (most #'length #("ab" "abc" "a" "efg"))) '("abc" 3))
(equal (multiple-value-list (most #'char-code "Is this not pung?")) '(#\u 117))
(equal (multiple-value-list (most #'abs #(-9 8 -7 3 25 0 -28))) '(-28 28))
(equal (multiple-value-list (most #'abs #(-9 8 -7 3 25 28 0 -28))) '(28 28))
(equal (multiple-value-list (most #'integer-length #(0 1 3 4 7 -1 -4 -7 -8))) '(4 3))
(equal (multiple-value-list (most #'integer-length (reverse #(0 1 3 4 7 -1 -4 -7 -8)))) '(-8 3))))
(equal '(nil nil) (multiple-value-list (most #'length '())))
(equal '(() 0) (multiple-value-list (most #'length '(()))) )
(equal '((A B) 2) (multiple-value-list (most #'length '((a b)))) )
(equal '((A) 1) (multiple-value-list (most #'length '((a) (b) (c) (d)))) )
(equal '((A B C) 3) (multiple-value-list (most #'length '((a b) (a b c) (a) (e f g)))) )
(equal '((e f g h i j) 6) (multiple-value-list (most #'length '((a b) (a b c) (a) (e f g h i j)))) )
(equal '(nil nil) (multiple-value-list (most #'char-code "")))
(equal '(#\a 97) (multiple-value-list (most #'char-code "a")))
(equal '(#\a 97) (multiple-value-list (most #'char-code "aaaaaaaaaa")))
(equal '(#\u 117) (multiple-value-list (most #'char-code "Is this not pung?")))
(equal '("abc" 3) (multiple-value-list (most #'length #("ab" "abc" "a" "efg"))))
(equal '("abcdefg" 7) (multiple-value-list (most #'length #("ab" "abc" "a" "abcdefg" "efg"))))
(equal '(nil nil) (multiple-value-list (most #'abs #())))
(equal '(8 8) (multiple-value-list (most #'abs #(8))))
(equal '(8 8) (multiple-value-list (most #'abs #(8 -8 8 -8))))
(equal '(-28 28) (multiple-value-list (most #'abs #(-9 8 -7 3 25 0 -28))))
(equal '(28 28) (multiple-value-list (most #'abs #(-9 8 -7 3 25 28 0 -28))))
(equal '(4 3) (multiple-value-list (most #'integer-length #(0 1 3 4 7 -1 -4 -7 -8))))
(equal '(-8 3) (multiple-value-list (most #'integer-length (reverse #(0 1 3 4 7 -1 -4 -7 -8)))) )))

(deftest test-least ()
(check
(equal '(nil nil) (multiple-value-list (least #'length '())))
(equal '(() 0) (multiple-value-list (least #'length '(()))) )
(equal '((A B) 2) (multiple-value-list (least #'length '((a b)))) )
(equal '((A) 1) (multiple-value-list (least #'length '((a) (b) (c) (d)))) )
(equal '((A) 1) (multiple-value-list (least #'length '((a b) (a b c) (a) (e f g)))) )
(equal '((a) 1) (multiple-value-list (least #'length '((a b) (a b c) (a) (e f g h i j)))) )
(equal '(nil nil) (multiple-value-list (least #'char-code "")))
(equal '(#\a 97) (multiple-value-list (least #'char-code "a")))
(equal '(#\a 97) (multiple-value-list (least #'char-code "aaaaaaaaaa")))
(equal '(#\space 32) (multiple-value-list (least #'char-code "Is this not pung?")))
(equal '("a" 1) (multiple-value-list (least #'length #("ab" "abc" "a" "efg"))))
(equal '("a" 1) (multiple-value-list (least #'length #("ab" "abc" "a" "abcdefg" "efg"))))
(equal '(nil nil) (multiple-value-list (least #'abs #())))
(equal '(8 8) (multiple-value-list (least #'abs #(8))))
(equal '(8 8) (multiple-value-list (least #'abs #(8 -8 8 -8))))
(equal '(0 0) (multiple-value-list (least #'abs #(-9 8 -7 3 25 0 -28))))
(equal '(-1 1) (multiple-value-list (least #'abs #(-9 8 -7 3 -1 25 28 1 -28))))
(equal '(0 0) (multiple-value-list (least #'integer-length #(0 1 3 4 7 -1 -4 -7 -8))))
(equal '(-1 0) (multiple-value-list (least #'integer-length (reverse #(0 1 3 4 7 -1 -4 -7 -8)))) )))

(deftest test-most-least ()
(check
(null (most-least #'length '()))
(equal (multiple-value-list (most-least #'length '((a b) (b c) (b a) (e f)))) '((A B) 2 (A B) 2))
(equal (multiple-value-list (most-least #'length '((a b) (a b c) (a) (e f g)))) '((A B C) 3 (A) 1))
(equal (multiple-value-list (most-least #'length '((a b)))) '((A B) 2 (A B) 2))
(equal (multiple-value-list (most-least #'length '((a b) (c d) (e f)))) '((A B) 2 (A B) 2))
(equal (multiple-value-list (most-least #'length #("ab" "abc" "a" "efg"))) '("abc" 3 "a" 1))
(equal (multiple-value-list (most-least #'char-code "Is this not pung?")) '(#\u 117 #\SPACE 32))
(equal (multiple-value-list (most-least #'char-code "a")) '(#\a 97 #\a 97))
(equal (multiple-value-list (most-least #'char-code "aaaaaaaa")) '(#\a 97 #\a 97))
(null (most-least #'abs #()))
(equal (multiple-value-list (most-least #'abs #(-9 8 -7 3 25 0 -28))) '(-28 28 0 0))
(equal (multiple-value-list (most-least #'abs #(-9 8 -7 3 25 28 0 -28))) '(28 28 0 0))
(equal (multiple-value-list (most-least #'abs #(8))) '(8 8 8 8))
(equal (multiple-value-list (most-least #'abs #(8 -8 8 -8))) '(8 8 8 8))
(equal (multiple-value-list (most-least #'integer-length #(0 1 3 4 7 -1 -4 -7 -8))) '(4 3 0 0))
(equal (multiple-value-list (most-least #'integer-length (reverse #(0 1 3 4 7 -1 -4 -7 -8)))) '(-8 3 -1 0))))
(equal '(nil nil nil nil) (multiple-value-list (most-least #'length '())))
(equal '(() 0 () 0) (multiple-value-list (most-least #'length '(()))) )
(equal '((A B) 2 (A B) 2) (multiple-value-list (most-least #'length '((a b)))) )
(equal '((A B) 2 (A B) 2) (multiple-value-list (most-least #'length '((a b) (b c) (b a) (e f)))) )
(equal '((A B C) 3 (A) 1) (multiple-value-list (most-least #'length '((a b) (a b c) (a) (z) (e f g)))) )
(equal '((e f g h i j) 6 (a) 1) (multiple-value-list (most-least #'length '((a b) (a b c) (a) (e f g h i j)))) )
(equal '(nil nil nil nil) (multiple-value-list (most-least #'char-code "")))
(equal '(#\a 97 #\a 97) (multiple-value-list (most-least #'char-code "a")))
(equal '(#\a 97 #\a 97) (multiple-value-list (most-least #'char-code "aaaaaaaa")))
(equal '(#\u 117 #\SPACE 32) (multiple-value-list (most-least #'char-code "Is this not pung?")))
(equal '("abc" 3 "a" 1) (multiple-value-list (most-least #'length #("ab" "abc" "a" "efg"))))
(equal '("abcdefg" 7 "ab" 2) (multiple-value-list (most-least #'length #("ab" "abc" "abcdefg" "efg"))))
(equal '(nil nil nil nil) (multiple-value-list (most-least #'abs #())))
(equal '(8 8 8 8) (multiple-value-list (most-least #'abs #(8))))
(equal '(8 8 8 8) (multiple-value-list (most-least #'abs #(8 -8 8 -8))))
(equal '(-28 28 0 0) (multiple-value-list (most-least #'abs #(-9 8 -7 3 25 0 -28))))
(equal '(28 28 0 0) (multiple-value-list (most-least #'abs #(-9 8 -7 3 25 28 0 -28))))
(equal '(4 3 0 0) (multiple-value-list (most-least #'integer-length #(0 1 3 4 7 -1 -4 -7 -8))))
(equal '(-8 3 -1 0) (multiple-value-list (most-least #'integer-length (reverse #(0 1 3 4 7 -1 -4 -7 -8)))) )))

(defclass dude ()
((name :reader name :initarg :name)
Expand Down

0 comments on commit a18a1a9

Please sign in to comment.