Refactor preference module to improve consistency.
parent
743d9a8c65
commit
0082ed981e
@ -0,0 +1,121 @@
|
|||||||
|
;;; 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))
|
||||||
|
|
||||||
|
;; 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
|
||||||
|
((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:
|
||||||
|
;; ((`ranking-1` . `count-1`) (`ranking-2` . `count-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
|
||||||
|
;; ((<ranking-1> . 1) (<ranking-2> . 1) ...)
|
||||||
|
(map cons rankings (const-list (length rankings) 1))))
|
||||||
|
))
|
||||||
|
|
||||||
|
|
@ -0,0 +1,102 @@
|
|||||||
|
;;; 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 (tests test-preference)
|
||||||
|
#:use-module (srfi srfi-64)
|
||||||
|
#:use-module (goblins)
|
||||||
|
#:use-module (goblins vrun)
|
||||||
|
#:use-module (goblins actor-lib methods)
|
||||||
|
#:use-module (deliberate preference))
|
||||||
|
|
||||||
|
(test-begin "test-deliberate-preference")
|
||||||
|
|
||||||
|
(define a-vat (spawn-vat))
|
||||||
|
(define-vat-run a-run a-vat)
|
||||||
|
|
||||||
|
;; Tests for ^alternatives
|
||||||
|
(define question "What type of generator should we install?")
|
||||||
|
(define alts (a-run (spawn ^alternatives question '("solar" "wind"))))
|
||||||
|
|
||||||
|
(test-equal "What type of generator should we install?"
|
||||||
|
(a-run ($ alts 'question)))
|
||||||
|
|
||||||
|
(test-equal '("solar" "wind")
|
||||||
|
(a-run ($ alts 'alternatives)))
|
||||||
|
|
||||||
|
(a-run ($ alts 'add "hydro"))
|
||||||
|
|
||||||
|
(test-equal '("hydro" "solar" "wind")
|
||||||
|
(a-run ($ alts 'alternatives)))
|
||||||
|
|
||||||
|
|
||||||
|
;; Tests for ^ranked-preference
|
||||||
|
(define alternatives
|
||||||
|
(a-run (spawn ^alternatives
|
||||||
|
question
|
||||||
|
'("solar" "wind" "hydro"))))
|
||||||
|
(define (f1 alts) '(1 2 3))
|
||||||
|
(define (f2 alts) '(2 3 1))
|
||||||
|
|
||||||
|
(define pref (a-run (spawn ^ranked-preference alternatives)))
|
||||||
|
|
||||||
|
(test-equal '()
|
||||||
|
(a-run ($ pref 'ranked)))
|
||||||
|
|
||||||
|
(test-equal #f
|
||||||
|
(a-run ($ pref 'rank-of "solar")))
|
||||||
|
|
||||||
|
(a-run ($ pref 'set f1))
|
||||||
|
|
||||||
|
(test-equal 1
|
||||||
|
(a-run ($ pref 'rank-of "solar")))
|
||||||
|
|
||||||
|
(test-equal 3
|
||||||
|
(a-run ($ pref 'rank-of "hydro")))
|
||||||
|
|
||||||
|
(test-equal #f
|
||||||
|
(a-run ($ pref 'rank-of "wildgoose")))
|
||||||
|
|
||||||
|
(a-run ($ pref 'set f2))
|
||||||
|
|
||||||
|
(test-equal 1
|
||||||
|
(a-run ($ pref 'rank-of "hydro")))
|
||||||
|
|
||||||
|
|
||||||
|
;; Tests for ^ranked-profile
|
||||||
|
(define profile (a-run (spawn ^ranked-profile alternatives)))
|
||||||
|
(define pref1 (a-run ($ profile 'add-preference)))
|
||||||
|
|
||||||
|
(test-equal '()
|
||||||
|
(a-run ($ pref1 'ranked)))
|
||||||
|
|
||||||
|
(define pref2 (a-run ($ profile 'add-preference)))
|
||||||
|
(a-run ($ pref1 'set f1))
|
||||||
|
(a-run ($ pref2 'set f2))
|
||||||
|
|
||||||
|
(define counts (a-run ($ profile 'counts)))
|
||||||
|
|
||||||
|
(test-equal '((("hydro" "solar" "wind") . 1)
|
||||||
|
(("solar" "wind" "hydro") . 1))
|
||||||
|
counts)
|
||||||
|
|
||||||
|
(test-equal '("hydro" "solar" "wind")
|
||||||
|
(car (car counts)))
|
||||||
|
|
||||||
|
(test-equal 1
|
||||||
|
(cdr (car counts)))
|
||||||
|
|
||||||
|
(test-equal '("solar" "wind" "hydro")
|
||||||
|
(car (cadr counts)))
|
||||||
|
|
||||||
|
(test-end "test-deliberate-preference")
|
Loading…
Reference in New Issue