Refactor preference module to improve consistency.

deliberate/preference.scm

@@ -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))))
+   ))
+
+

tests/test-preference.scm

@@ -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")