goblins-deliberate/deliberate/preference.scm

;;; Copyright 2022 Edward L. Platt
;;;
;;; Licensed under the Apache License, Version 2.0 (the "License");
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;;
;;;     http://www.apache.org/licenses/LICENSE-2.0
;;;
;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;;; See the License for the specific language governing permissions and
;;; limitations under the License.

(define-module (deliberate preference)
  #:use-module (srfi srfi-1)
  #:use-module (goblins)
  #:use-module (goblins vrun)
  #:use-module (goblins actor-lib methods)
  #:use-module (deliberate utils)
  #:export (^alternatives ^ranked-preference ^ranked-profile
	    pref-count pref-ranked))

;; Constructor for ^alternatives
;; A set of alternative outcomes to a question.
;;
;; Parameters:
;;   question: String describing the question being considered
;;   alternatives: list of strings describing possible alternatives
;;
;; Messages:
;;   question: Return the question string
;;   alternatives: Return the current list of alternatives
;;   add-alternative: Add an alternative to the list
;;
(define (^alternatives bcom question alternatives)
  (define alts-cell (spawn ^cell alternatives))
  (methods
   ((question) question)
   ((alternatives) ($ alts-cell 'get))
   ((add alt)
    ($ alts-cell 'set (cons alt ($ alts-cell 'get))))
   ))
		       
;; Constructor for ^ranked-preference
;; One constituent's preferences as an ordered ranking.
;;
;; Preferences model a single constituent's preference on a specific question.
;; Ranked preferenes model constituent preferences as an ordered relationship
;; between a finite list of possible alternatives.
;;
;; ^ranked-preference is associated with a set of alternatives at creation.
;; The initial ranking is empty.
;;
;; Preferences are updated by passing a function mapping alternatives to
;; their ranks, which ensures consistency between the alternatives and the
;; elements of the ranking.
;;
;; Parameters:
;;   alternatives: An ^alternatives object
;;
;; Messages:
;;   ranked: Return the ranked list of alternatives
;;   rank-of alternative: Return the rank of alternative (1 is most
;;     preferred) or #f if not present in the ranking
;;   set f: Update the ranking according to a function mapping alternatives
;;     to their rank position.
;;
(define (^ranked-preference _bcom alternatives)
  (define ranking (spawn ^cell '()))
  (methods
   ((alternatives) alternatives)
   ((ranked) ($ ranking 'get))
   ((rank-of alternative)
    (let ((alt-index
	   (list-index
	    (lambda (alt) (equal? alt alternative))
	    ($ ranking 'get))))
      (if (number? alt-index)
	  (+ 1 alt-index)
	  #f)))
   ((set f)
    (let* ((alt-list ($ alternatives 'alternatives))
	   (ranks (f alt-list))
	   (new-ranking (reorder alt-list ranks)))
      ($ ranking 'set new-ranking)))
   ))

;; Constructor for ^ranked-profile
;; A preference profile for ordered rankings.
;;
;; Preference profiles represent the preferences of a group of constituents
;; on a specific question. Ranked preferences model constituent preferences as
;; an ordered relationships between a finite list of possible alternatives.
;;
;; Parameters:
;;   alternatives: An ^alternatives object
;;
;; Messages:
;;   add-preference: Create and track a new ^ranked-preference as part of this
;;     profile. The new object is returned.
;;   counts: Returns a list representing all preference rankings in the
;;     profile. The list is of the form:
;;     ((`count-1` . `ranking-1`) (`count-2` . `ranking-2`) ...)
;;     where `ranking-n` is a list of strings, and `count-n` is the number
;;     of times that ranking appears in this profile.
;;
(define (^ranked-profile _bcom alternatives)
  (define preferences (spawn ^cell '()))
  (methods
   ((add-preference)
    (let ((pref (spawn ^ranked-preference alternatives)))
      ($ preferences 'set (cons pref ($ preferences 'get)))
      pref))
   ((counts)
    (let ((rankings (map (lambda (pref) ($ pref 'ranked))
			 ($ preferences 'get))))
      ;; This is an inefficent represntation but OK for now
      ;; ((1 . `ranking-1`) (1 . `ranking-2`) ...) 
      (map cons
	   (const-list (length rankings) 1)
	   rankings)))
   ))

;; Abstraction for working with ranking data
;;
(define pref-count car)
(define pref-ranked cdr)