;This phile is ungoverned by the Cypherpunks' Anti-License.  Do with it
;whatsoever thou wilt, individual.

;This phile is all of the following, maximally interpreted:
;Anti-licensed, copyleft, free as in beer, free as in speech, freeware,
;non-classified, nonproprietary, open source, public domain,
;ungoverned, unlicensed.

;An attempt to model subjective preference as an "order" relation.  The
;domain of preference is to consist of members identified as string.
;This field could be called "mnemonic" and the structure/union (or lisp
;'analogue') having this field as a member could be arrangeable into a
;"ranked" but not "strictly ranked" data structure.  This structure
;will also have lt and gt fields.  For now, we shall model the
;structure as a plist or "property list" in the Common Lisp sense.  For
;now, we shall call this structure a 'preferand.'

;This is the query function, which will return -1, 0, or 1 as first
;preferand operand is (respectively) subjectively 'dominated' by the
;second, subjectively of equivalent 'value' to the second operand, or
;preferred over the second preferand operand.

(defun make-preferand (text)
 (if (stringp text)
  (let ((new-symbol (make-symbol "preferand")))
   (setf (get new-symbol 'mnemonic) text)
   new-symbol)))

(defun preferand-p (s)
 (and
  (symbolp s)
  (get s 'mnemonic)))

;preferand-cmp is to preferand as C's strcmp is to strings

(defun preferand-cmp (preferand1 preferand2)
 (if (and (preferand-p preferand1) (preferand-p preferand2))
  (let*
   ((preferands (cons preferand1 preferand2))
    (mnemonics (cons (get (car preferands) 'mnemonic) (get (cdr preferands) 'mnemonic)))
    answer)
   (print mnemonics)
   (print "Pleaze indicate preference.")
   (print "Pleaze enter 'car' or 'a' to indicate a preference for:")
   (print (car mnemonics))
   (print "Pleaze enter 'cdr' or 'd' to indicate a preference for:")
   (print (cdr mnemonics))
   (print "Pleaze enter 'nil' to indicate no preference between the two.")
   (setf answer (read))
   (cond
    ((member answer '(a car)) 1)
    ((null answer) 0)
    ((member answer '(d cdr)) -1)
    (t (error "Valid inputs are (a car d cdr nil)"))))))

;preferand-le is to preferand as <= is to number

(defun preferand-le (preferand1 preferand2)
 (if (plusp (preferand-cmp preferand1 preferand2)) nil t))

(setf radio-names-list (list
; AAR weekday personalities
 "rachel maddow[sp?]"
 "jerry springer"
 "al franken"
 "randi rhodes"
 "mike malloy"
; NPR and other noncommercial weekday personalities
 "diane rehm"
 "ed gordon"
 "amy goodman and juan gonzalez"
 "neil[sp?] conen[sp?]"
; misc. commercial weekdays
 "michael eric dyson[sp?]"
 "al sharpton"
 "ed schultz"
 "lionel"
; (mostly?) AAR weekend (in Detroit market)
 "thom hartmann"
 "jesse jackson"
 "angie koiro[sp?]"
 "mark[?] binder[sp?]"
 "rfk jr. and mike pappantonio[sp?]"
 "laura flanders"
; local Detroit talent
 "peter werbe"))

(print radio-names-list)

(setf preferand-list (mapcar #'make-preferand radio-names-list))

(print preferand-list)

; operations up to this point seem to be working

(defun rank-preferand-list (preferand-list)
 (stable-sort preferand-list #'preferand-le))

;Following (listed as mnemonics, of course) is the ranking I got:

;("rachel maddow[sp?]" "lionel" "thom hartmann" "al franken"
; "neil[sp?] conen[sp?]" "diane rehm" "al sharpton" "ed gordon"
; "michael eric dyson[sp?]" "jesse jackson" "mark[?] binder[sp?]"
; "rfk jr. and mike pappantonio[sp?]" "angie koiro[sp?]" "mike malloy"
; "peter werbe" "laura flanders" "amy goodman and juan gonzalez")

;As can be seen, the bottom ranking entries seem to be missing.  A
;total of 3 names seem to be missing from the list.  Perhaps this is
;due to handling of equal preference.

;Also, redundant questions were asked by the stable-sort algorithm.
;This may be due to the lack of persistent memory in the preferand-le
;function, which would be correctable using static local variables.

;Here is an attempt at a solution using static local variables.

(defun new-preferand-le (&rest preferands)
 (declare (preflist)
  (setf preflist
   (cons
    (if (plusp (cmp (car preferands) (cadr preferands))) (reverse preferands) preferands)
    preflist))
))

;From here on in, things aren't yet (as of 20 June 2006) debugged.

;Back to the data structure for ranking.  We shall call it a
;'preferand-ranking.'

(defun preferand-ranking-p (s)
 (symbolp s))

(defun make-preferand-ranking nil
 (make-symbol "preferand-ranking"))

;(defun rank-preferand-list (preferand-list)
; (let ((preferand-ranking (make-preferand-ranking)))
;  (mapcar
;   #'(lambda (s) (rank-preferand s preferand-ranking))
;   preferand-list)))

(defun rank-preferand (preferand preferand-ranking)
 (let*
  ((mnemonic (get preferand 'mnemonic))
   (top-level
    (sort
     (remove-if #'null (cons preferand (list
      (get preferand-ranking 'lt)
      (get preferand-ranking 'eq)
      (get preferand-ranking 'gt))))
     #'preferand-le))
   (odd-1-out
    (if
     (= (length top-level) 4)
     (if (zerop (random 2)) (car top-level) (car (last top-level)))))
   (value preferand-ranking)
   (even-3-in
    (cond
     ((null odd-1-out) top-level)
     ((eq (car top-level) odd-1-out)
      (cdr top-level))
     (t (reverse (cdr (reverse top-level)))))))
; end let* binding
; start functional code
; diagnostic prints:
 (print "verifying local bindings complete for rank-preferand:")
 (print
  `(mnemonic ,mnemonic
    top-level ,top-level
    odd-1-out ,odd-1-out
    value ,value
    even-3-in ,even-3-in))
 (setf
  (get value 'lt) (first even-3-in)
  (get value 'eq) (second even-3-in)
  (get value 'gt) (third even-3-in))
; recursive call follows:
 (cond
  ((eq (car top-level) odd-1-out)
   (rank-preferand preferand (get value 'lt)))
  (odd-1-out
   (rank-preferand preferand (get value 'gt)))
  (t value))
))