;===========================================================================
; blurred-proto.ss :  Guess based on blurred-prototypes.
;===========================================================================
; globals: *blurred-prototypes*
;          *quanta*
;---------------------------------------------------------------------------
; Guess a winner using a city-block computation from the blurred-prototypes.

; Pick a winner by guessing.  The code sorts the distances and
; picks the "closest" one to the token specified in *quanta*.
(define guess-winner
  (lambda ()
    (caar (sort (lambda (x y)
		  (> (cadr x)
		     (cadr y))) (make-prototype-value-list
				 *quanta* *blurred-prototypes*)))))

; Make a list of the 26 distances between a given token and the blurred-protos
(define make-prototype-value-list
  (lambda (qls pls)
    (cond
     [(null? pls) '()]
     [else (cons (list (caar pls)
		       (make-prototype-value qls (cadar pls)))
		 (make-prototype-value-list qls (cdr pls)))])))

; Given a token, compute its "distance" from a category using the
; blurred-prototypes list below.
; Distance == If quanta is on, add the value else subtract it.  Get a total.
(define make-prototype-value
  (lambda (qls letvals)
    (cond
     [(null? letvals) 0]
     [(= 1 (car qls)) (+ (car letvals)
			     (make-prototype-value (cdr qls) (cdr letvals)))]
     [else (- (make-prototype-value (cdr qls) (cdr letvals))
	      (car letvals))])))

; Blurred prototypes created over the entire PSYCH data set (NORMALS+FONTS)
; This is made by adding all vectors in a letter category and dividing by
; the total number of tokens.  The result is a 56-d vector with a value
; for each quantum representing its strength.
(set! *blurred-prototypes*
      '(
(?a (0 0 0 0 0.579 0.421 0.579 0.474 0.684 0.368 0 0 0 0 0 0 0 0 0 0 0.053 0 0.474 0.316 0.053 0.789 0 0 0 0 0 0 0 0 0 0 0.211 0.263 0.421 0.632 0 0 0 0 0 0 0 0 0.105 0.421 0.368 0.158 0 0 0 0))
(?b (0 0 0 0 0.556 0.333 0.056 0.056 0.444 0.556 0 0 0 0 0.833 0.056 0 1.000 0 0 0.944 0 0.444 0.722 0.056 0.500 0 0 0 0 0 0 0.056 0 0 0 0.222 0.111 0.167 0.389 0 0 0 0 0.056 0 0 0 0.056 0.500 0.556 0.056 0 0 0 0))
(?c (0 0 0 0 0.312 0.562 0.062 0 0.312 0.562 0 0 0 0 0 0 0 0 0 0 0.312 0 0 0.250 0 0.188 0 0 0 0 0 0 0 0 0 0 0.562 0.062 0.062 0.312 0 0 0 0 0 0 0 0 0.125 0.188 0.562 0.188 0 0 0 0))
(?d (0 0 0 0 0.368 0.579 0.053 0.053 0.474 0.474 0 0 0 0 0 0.053 0.842 0 0 1.000 0.368 0 0.947 0.421 0.053 0.737 0 0 0 0 0 0 0 0.053 0 0 0.526 0.053 0.053 0.474 0 0 0 0 0 0.053 0 0 0.105 0.263 0.421 0.158 0 0 0 0))
(?e (0 0 0 0 0.455 0.682 0.500 0.500 0.455 0.591 0 0 0 0 0 0 0 0 0 0 0.409 0 0.273 0.455 0 0.045 0 0 0 0 0 0 0 0 0 0 0.500 0.545 0.227 0.273 0 0 0 0 0 0 0 0 0.182 0.318 0.409 0.091 0 0 0 0))
(?f (0.059 0.235 0.118 0.118 0.706 0.647 0 0 0 0 0 0 0 0 0.118 0.412 0.176 0.118 0.588 0 0.059 0.824 0 0.059 0.824 0 0 0 0 0 0 0 0.118 0.294 0 0.059 0.235 0 0 0 0 0 0 0 0.059 0.353 0.235 0.118 0.059 0.176 0.118 0.059 0 0 0 0))
(?g (0 0 0 0 0.381 0.476 0.048 0.048 0.429 0.429 0 0 0.286 0.286 0 0 0 0 0 0 0.333 0.048 0.762 0.429 0 0.952 0 0 0.952 0.143 0.048 0.333 0 0 0 0 0.571 0.095 0.095 0.381 0.048 0.048 0 0.524 0 0 0 0 0.048 0.524 0.429 0.095 0 0.095 0.429 0.048))
(?h (0 0 0 0 0.400 0.267 0 0 0.067 0.067 0 0 0 0 0.733 0.067 0 1.000 0 0 0.933 0.200 0.400 0.667 0.200 0.800 0 0 0 0 0 0 0.133 0 0 0 0.400 0.133 0.200 0.067 0 0 0 0 0.067 0 0 0 0.067 0.400 0.267 0.133 0 0 0 0))
(?i (0.048 0 0.190 0 0.429 0 0.048 0 0 0.048 0 0 0 0 0 0.095 0 0.095 0.048 0 0.190 0.667 0 0.238 0.571 0.048 0 0 0 0 0 0 0.381 0 0.143 0 0.190 0 0.190 0 0 0 0 0 0.286 0 0.048 0.048 0.095 0 0.048 0.048 0 0 0 0))
(?j (0.069 0.034 0.138 0.069 0.345 0.172 0.034 0 0 0 0 0 0.103 0.069 0.034 0.103 0 0.034 0.034 0 0 0.690 0.138 0.034 0.724 0.172 0 0.724 0.207 0.069 0.379 0.034 0.310 0.138 0.172 0 0.172 0 0 0 0.034 0 0.345 0.138 0.207 0.034 0.034 0.034 0.069 0.034 0.034 0.034 0.034 0.034 0.379 0))
(?k (0 0 0 0 0.211 0.263 0.421 0.263 0.053 0.158 0 0 0 0 0.789 0.053 0 1.000 0 0 0.842 0.105 0.105 0.789 0.105 0.211 0 0 0 0 0 0 0.105 0 0 0 0.211 0.579 0.211 0.053 0 0 0 0 0.053 0 0 0 0.316 0.158 0.211 0.632 0 0 0 0))
(?l (0.188 0.062 0 0 0 0 0 0 0.062 0.125 0 0 0 0 0.188 0.688 0 0.312 0.688 0 0.250 0.688 0 0.062 0.688 0.062 0 0 0 0 0 0 0.188 0 0 0 0 0 0.125 0.188 0 0 0 0 0.062 0 0 0 0.062 0 0.188 0.125 0 0 0 0))
(?m (0 0 0 0 0.280 0.240 0.040 0.040 0.040 0 0 0 0 0 0 0 0 0 0 0 0.480 0.640 0.600 0.840 0.680 0.880 0 0 0 0 0 0 0 0 0 0 0.480 0.400 0.040 0.080 0 0 0 0 0 0 0 0 0.360 0.360 0.120 0.040 0 0 0 0))
(?n (0 0 0 0 0.353 0.353 0 0 0.059 0 0 0 0 0 0 0 0 0 0 0 0.471 0.176 0.412 0.706 0.235 0.824 0 0 0 0 0 0 0 0 0 0 0.471 0.118 0.118 0.059 0 0 0 0 0 0 0 0 0.176 0.412 0.176 0.118 0 0 0 0))
(?o (0 0 0 0 0.500 0.450 0.050 0 0.450 0.500 0 0 0 0 0 0 0 0 0 0 0.400 0.100 0.450 0.400 0 0.550 0 0 0 0 0 0 0 0 0 0 0.300 0.150 0.250 0.300 0 0 0 0 0 0 0 0 0.200 0.400 0.350 0.150 0 0 0 0))
(?p (0 0 0 0 0.433 0.367 0.067 0.100 0.600 0.367 0 0 0 0 0 0 0 0 0 0 0.600 0.100 0.533 0.833 0.033 0.400 0.967 0 0 0.833 0.033 0 0 0 0 0 0.367 0.167 0.233 0.500 0 0 0.067 0 0 0 0 0 0.133 0.400 0.267 0.100 0.033 0 0.067 0))
(?q (0 0 0 0 0.300 0.500 0.133 0.033 0.567 0.500 0 0 0.033 0.200 0 0 0 0 0 0 0.333 0.133 0.767 0.433 0.067 0.867 0 0.033 0.867 0 0.100 0.600 0 0 0 0 0.433 0.200 0.267 0.400 0 0.100 0.033 0.300 0 0 0 0 0.033 0.367 0.267 0.100 0 0 0 0.033))
(?r (0 0 0 0 0.200 0.600 0.050 0.100 0.050 0 0 0 0 0 0 0 0 0 0 0 0.500 0.050 0.350 0.700 0.150 0 0 0 0 0 0 0 0 0 0 0 0.650 0.250 0.100 0 0 0 0 0 0 0 0 0 0.100 0.350 0.100 0.050 0 0 0 0))
(?s (0 0 0 0 0.500 0.455 0.545 0.455 0.682 0.636 0 0 0 0 0 0 0 0 0 0 0.227 0.091 0.091 0.091 0 0.182 0 0 0 0 0 0 0 0 0 0 0.273 0.091 0.091 0.318 0 0 0 0 0 0 0 0 0.273 0.364 0.227 0.455 0 0 0 0))
(?t (0 0 0 0 0.611 0.833 0 0.056 0.111 0.222 0 0 0 0 0 0.056 0 0.056 0.889 0 0.111 0.833 0 0 0.611 0.222 0 0 0 0 0 0 0 0 0.111 0 0.278 0 0.111 0.333 0 0 0 0 0 0 0.056 0 0.056 0 0.111 0.222 0 0 0 0))
(?u (0 0 0 0 0 0.048 0 0.048 0.619 0.286 0 0 0 0 0 0 0 0 0 0 0.619 0.286 0.667 0.476 0.143 0.762 0 0 0 0 0 0 0 0 0 0 0.143 0.048 0.286 0.476 0 0 0 0 0 0 0 0 0.095 0.190 0.286 0.095 0 0 0 0))
(?v (0 0 0 0 0 0.048 0.095 0.095 0 0 0 0 0 0 0 0 0 0 0 0 0.476 0.190 0.429 0.190 0.333 0.143 0 0 0 0 0 0 0 0 0 0 0.238 0.286 0.190 0.476 0 0 0 0 0 0 0 0 0.286 0.190 0.524 0.143 0 0 0 0))
(?w (0 0 0 0 0 0.037 0 0 0.370 0.259 0 0 0 0 0 0 0 0 0 0 0.852 0.556 0.852 0.593 0.741 0.593 0 0 0 0 0 0 0 0 0 0 0.111 0.037 0.370 0.333 0 0 0 0 0 0 0 0 0.037 0.111 0.407 0.333 0 0 0 0))
(?x (0 0 0 0 0.263 0.158 0.053 0.053 0.211 0.211 0 0 0 0 0 0 0 0 0 0 0.263 0.474 0.263 0.053 0.211 0.263 0 0 0 0 0 0 0 0 0 0 0.211 0.842 0.895 0 0 0 0 0 0 0 0 0 0.526 0.211 0.053 0.789 0 0 0 0))
(?y (0 0 0 0 0.037 0.037 0.074 0 0.407 0.333 0 0 0.444 0.111 0 0 0 0 0 0 0.704 0.148 0.815 0.370 0.074 0.926 0.074 0 0.889 0.296 0.037 0.148 0 0 0 0 0.111 0.037 0.111 0.556 0.037 0.111 0.185 0.667 0 0 0 0 0.148 0.111 0.370 0.148 0 0.074 0.259 0.037))
(?z (0 0 0 0 0.438 0.688 0 0.125 0.938 0.750 0 0.062 0 0 0 0 0 0 0 0 0.375 0.062 0 0 0 0.188 0 0 0 0 0 0 0 0 0 0 0.312 0.750 0.875 0.250 0 0 0 0 0 0 0 0 0.125 0.062 0.062 0.125 0.062 0 0 0))))

; Make a list of the 26 distances between a given token and the blurred-protos
(define make-square-value-list
  (lambda (qls pls)
    (cond
     [(null? pls) '()]
     [else (cons (list (caar pls)
		       (make-square-value qls (cadar pls)))
		 (make-square-value-list qls (cdr pls)))])))

(define make-square-value
  (lambda (qls letvals)
    (cond
     [(null? letvals) 0]
     [else (+ (make-square-value (cdr qls) (cdr letvals))
	   (abs (- (car qls)  (car letvals))) )])))

(define overlapAmt
  (lambda (ls1 ls2 n)
    (cond
      ((or (null? ls1) (null? ls2)) n)
      (else (+ (memberAmt ls2 (car ls1)) (overlapAmt ls2 (cdr ls1) n))))))

(define memberAmt
  (lambda (ls item)
    (cond
     ((null? ls) n)
     ((memq? item ls) 1)
     (else 0))))

;ascender and descender zone quanta yanked from squares 5..9
(define q-to-squares
  (lambda ()
    (set! *squares*
	  (list
	   (overlapAmt '(0 2 14 15 32 44) *quanta-list* 0)
	   (overlapAmt '(1 3 15 16 33 45) *quanta-list* 0)
	   (overlapAmt '(17 18 2 34 46) *quanta-list* 0)
	   (overlapAmt '(18 19 3 35 47) *quanta-list* 0)
	   (overlapAmt '(20 21 4 6 36 48) *quanta-list* 0)
	   (overlapAmt '(21 22 5 7 37 49) *quanta-list* 0)
	   (overlapAmt '(23 24 6 8 38 50) *quanta-list* 0)
	   (overlapAmt '(24 25 7 9 39 51) *quanta-list* 0)
	   (overlapAmt '(26 27 10 40 52) *quanta-list* 0)
	   (overlapAmt '(27 28 11 41 53) *quanta-list* 0)
	   (overlapAmt '(29 30 10 12 42 54) *quanta-list* 0)
	   (overlapAmt '(30 31 11 13 43 55) *quanta-list* 0)))))

(define tip?
  (lambda (ls)
	   (cond
	    ((eq? 1 (overlapAmt ls *quanta-list* 0)) 1)
	    (else 0))))

;only needs to be called once per input

(define tips-to-squares
  (lambda ()
    (let
	([vert1 (tip? '(0 14 44))]
	 [vert2 (tip? '(14 32 2 46 17))]
	 [vert3 (tip? '(17 34 4 48 20))]
	 [vert4 (tip? '(20 36 6 50 23))]
	 [vert5 (tip? '(23 38 8 52 26))]
	 [vert6 (tip? '(26 40 10 54 29))]
	 [vert7 (tip? '(29 42 12))]
	 [vert8 (tip? '(0 1 15 32 45))]
	 [vert9 (tip? '(15 33 3 47 18 34 2 44))]
	 [vert10 (tip? '(18 35 5 49 21 36 4 46))]
	 [vert11 (tip? '(21 37 7 51 24 38 6 48))]
	 [vert12 (tip? '(24 39 9 53 27 40 8 50))]
	 [vert13 (tip? '(27 41 11 55 30 42 10 52))]
	 [vert14 (tip? '(12 13 54 30 43))]
	 [vert15 (tip? '(1 33 16))]
	 [vert16 (tip? '(16 45 3 35 19))]
	 [vert17 (tip? '(19 47 5 37 22))]
	 [vert18 (tip? '(22 49 7 39 25))]
	 [vert19 (tip? '(25 51 9 41 28))]
	 [vert20 (tip? '(28 53 11 43 31))]      
	 [vert21 (tip? '(31 55 13))])
      (set! *tip-squares*
	    (list
	     (+ vert1 vert2 vert8 vert9)
	     (+ vert8 vert9 vert15 vert16)
	     (+ vert2 vert3 vert9 vert10)
	     (+ vert9 vert10 vert16 vert17)
	     (+ vert3 vert4 vert10 vert11)
	     (+ vert10 vert11 vert17 vert18)
	     (+ vert4 vert5 vert11 vert12)
	     (+ vert11 vert12 vert18 vert19)
	     (+ vert5 vert6 vert12 vert13)
	     (+ vert12 vert13 vert19 vert20)
	     (+ vert6 vert7 vert13 vert14)
	     (+ vert13 vert14 vert20 vert21))))))

(set! *square-prototypes*
      '(
(?a (0 0 0 0 1.53 2.05 2.42 2.47 0 0 0 0))
(?b (1 0.06 1 0 1.83 1.44 2 1.61 0 0 0 0))
(?c (0 0 0 0 1.38 0.81 1.25 1.25 0 0 0 0))
(?d (0.05 1 0 1 1.42 1.9 1.48 1.95 0 0 0 0))
(?e (0 0 0 0 2.05 2.32 2.05 1.5 0 0 0 0))
(?f (0.88 1.59 1.06 0.88 1.88 1.65 1 0.88 0 0 0 0))
(?g (0 0 0 0 1.43 1.95 1.43 1.91 0.05 1.1 0.91 1.24))
(?h (1 0.07 1 0 2 1.4 1.4 1.27 0 0 0 0))
(?i (1 0.1 0.52 0.1 1.62 0.67 1.1 0.72 0 0 0 0))
(?j (0.86 0.38 0.41 0.14 1.31 1.03 0.83 0.93 0.79 0.97 1.28 0.62))
(?k (1 0.05 1 0 2.11 1.47 1.79 1.42 0 0 0 0))
(?l (1.31 0.75 1 0.69 1 0.69 1.13 1.19 0 0 0 0))
(?m (0 0 0 0 2.28 2.28 1.76 1.72 0 0 0 0))
(?n (0 0 0 0 1.65 1.47 1.29 1.24 0 0 0 0))
(?o (0 0 0 0 1.55 1.55 1.5 1.5 0 0 0 0))
(?p (0 0 0 0 1.7 1.67 2.03 1.5 1 0 1 0.03))
(?q (0 0 0 0 1.37 2 1.73 1.97 0.03 1 0.17 1.23))
(?r (0 0 0 0 1.55 1.7 1.15 0.3 0 0 0 0))
(?s (0 0 0 0 1.91 1.55 1.64 2.05 0 0 0 0))
(?t (0.06 0.06 1.11 0.89 1.89 1.72 0.94 1.67 0 0 0 0))
(?u (0 0 0 0 1.14 1.29 1.81 1.81 0 0 0 0))
(?v (0 0 0 0 1.29 1.24 1.33 1.19 0 0 0 0))
(?w (0 0 0 0 1.56 1.59 2.48 2.26 0 0 0 0))
(?x (0 0 0 0 1.79 2 1.48 1.53 0 0 0 0))
(?y (0 0 0 0 1.22 1.15 1.41 2.04 0.11 1.07 1.22 1))
(?z (0 0 0 0 1.31 1.69 1.88 1.44 0.06 0.06 0 0.06))))

; edited i row
(set! *tip-prototypes*
      '(
(?a (0 0 0.684 0.053 1.053 0.211 0.421 0.632 0.526 0 0 0))
(?b (1 0.111 0.278 0.167 0.056 0.056 0.389 0 0.389 0.111 0 0))
(?c (0 0 0.125 0.75 0.25 1.438 0.125 1.25 0.562 0 0 0))
(?d (0.105 1 0.158 0.947 0.053 0.053 0 0.316 0.316 0.105 0 0))
(?e (0 0 0 0.045 0.091 0.455 0.091 1.045 0.636 0 0 0))
(?f (0 0.941 0.588 1.118 0.824 0.941 1.118 1.059 0.118 0.824 0 0))
(?g (0 0 0 0.381 0 0.381 0.095 0.095 0.524 0.238 0.952 0.19))
(?h (1 0.2 0.267 0.133 0 0.067 1 1.133 1.4 0.533 0 0))
(?i (1.0 0.952 1.0 1.4 1.143 0.524 1.048 0.571 0.476 1.429 0 0))
(?j (1.483 1.103 1.897 1.241 1.103 0.552 0.207 0.069 0.414 0.966 0.931 0.140))
(?k (1 0.158 0.263 0.895 0.053 1.053 0.842 1.263 1.632 0.263 0 0))
(?l (0.938 0.5 0.375 0.25 0.062 0.312 0.562 0.875 0.312 0.812 0 0))
(?m (0 0 0.28 0.04 0.48 0.24 1.88 1.88 1.84 0.76 0 0))
(?n (0 0 0.353 0.059 0.471 0.176 1.176 1.118 1.706 0.176 0 0))
(?o (0 0 0.1 0.05 0.15 0.05 0.05 0 0 0 0 0))
(?p (0 0 0.267 0 0.333 0 0.1 0.033 0.067 0.1 1 0.1))
(?q (0 0 0 0.233 0.033 0.267 0.067 0.067 0.167 0.067 0.067 0.272))
(?r (0 0 0.45 0.45 0.7 1.05 1.2 0.75 0.9 0.1 0 0))
(?s (0 0 0.136 0.682 0.318 1 1 0.364 0.773 0.045 0 0))
(?t (1 0.889 1.667 1.722 0.889 1.389 0.444 1 0.222 1.167 0 0))
(?u (0 0 1.190 1.238 1.238 1.286 0.143 0.619 0.476 0.095 0 0))
(?v (0 0 1.238 1.238 1.238 1.238 0 0 0 0 0 0))
(?w (0 0 1.556 1.593 1.889 1.926 0.370 0.370 0 0.037 0 0))
(?x (0 0 0.737 0.842 1.263 1.211 1.526 1.368 1.474 0.263 0 0))
(?y (0 0 0.926 1 1.074 1.074 0.259 0.111 0.519 0.259 0.889 0.259))
(?z (0 0 0.5 0.25 1 0.75 0.5 1.062 0.625 0 0 0.062))))

(set! *closure-prototypes* '((?a 1) (?b 1) (?c 0) (?d 1) (?e 1) (?f 0)
      (?g 1) (?h 0) (?i 0) (?j 0) (?k 0) (?l 0) (?m 0) (?n 0) (?o 1)
      (?p 1) (?q 1) (?r 0) (?s 0) (?t 0) (?u 0) (?v 0) (?w 0) (?x 0)
      (?y 0) (?z 0)))

(set! *ascend-prototypes* '((?a 0) (?b 1) (?c 0) (?d 1) (?e 0) (?f 1)
      (?g 0) (?h 1) (?i 1) (?j 1) (?k 1) (?l 1) (?m 0) (?n 0) (?o 0)
      (?p 0) (?q 0) (?r 0) (?s 0) (?t 1) (?u 0) (?v 0) (?w 0) (?x 0)
      (?y 0) (?z 0)))

(set! *descend-prototypes* '((?a 0) (?b 0) (?c 0) (?d 0) (?e 0) (?f 0)
      (?g 1) (?h 0) (?i 0) (?j 1) (?k 0) (?l 0) (?m 0) (?n 0) (?o 0)
      (?p 1) (?q 1) (?r 0) (?s 0) (?t 0) (?u 0) (?v 0) (?w 0) (?x 0)
      (?y 1) (?z 0)))