Fixed typechecking of imaginaries.

original commit: dbdbaed50600b7ce47e2dacc12ba1e6f2a0345b4

collects/tests/typed-scheme/xfail/priority-queue.scm

@@ -0,0 +1,101 @@
+#lang typed-scheme
+;;; priority-queue.scm  --  Jens Axel Søgaard
+;;; PURPOSE
+
+; This file implements priority queues on top of
+; a heap library.
+(define-type-alias number Number)
+(define-type-alias boolean Boolean)
+(define-type-alias symbol Symbol)
+(define-type-alias top Any)
+(define-type-alias list-of Listof)
+(require (prefix-in heap: "leftist-heap.ss")
+	 (except-in (lib "67.ss" "srfi") number-compare current-compare =? <?)
+	 (only-in "leftist-heap.ss" comparator))
+(require/typed number-compare (number number -> number) (lib "67.ss" "srfi"))
+(require/typed current-compare (-> (top top -> number)) (lib "67.ss" "srfi"))
+(require/typed =? ((top top -> number) top top -> boolean) (lib "67.ss" "srfi"))
+(require/typed <? ((top top -> number) top top -> boolean) (lib "67.ss" "srfi"))
+
+; a priority-queue is a heap of  (cons <priority> <element>)
+
+(define-type-alias (elem a) (cons number a))
+
+(define-typed-struct (a) priority-queue ([heap : (heap:Heap (elem a))]))
+
+(define-type-alias (pqh a) (heap:Heap (elem a)))
+
+; conveniences
+(pdefine: (a) (heap [pq : (priority-queue a)]) : (pqh a) (priority-queue-heap pq))
+(pdefine: (a) (pri [p : (elem a)]) : number (car p))
+(pdefine: (a) (elm [p : (elem a)]) : a  (cdr p))
+(pdefine: (a) (make [h : (pqh a)]) : (priority-queue a)  (make-priority-queue h))
+
+; sort after priority
+; TODO: and then element?
+(pdefine: (a) (compare [p1 : (elem a)] [p2 : (elem a)]) : number
+	  (number-compare (pri p1) (pri p2)))
+
+;;; OPERATIONS
+
+(define: (num-elems [h : (heap:Heap (cons number number))]) : (list-of (cons number number))
+  (heap:elements h))
+
+(pdefine: (a) (elements [pq : (priority-queue a)]) : (list-of a)
+          (map #{elm :: ((elem a) -> a)} (heap:elements (heap pq))))
+
+(pdefine: (a) (elements+priorities [pq : (priority-queue a)]) : (values (list-of a) (list-of number))
+	  (let: ([eps : (list-of (elem a)) (heap:elements (heap pq))])
+		(values (map #{elm :: ((elem a) -> a)} eps)
+			(map #{pri :: ((elem a) -> number)} eps))))
+
+(pdefine: (a) (empty? [pq : (priority-queue a)]) : boolean
+	  (heap:empty? (heap pq)))
+
+(define: empty : (All (a) (case-lambda (-> (priority-queue a)) (comparator -> (priority-queue a))))
+  (pcase-lambda: (a)
+		 [()    (#{empty @ a} (current-compare))]
+		 [([cmp : comparator]) (make (#{heap:empty :: (case-lambda (-> (pqh a))
+									   (comparator -> (pqh a)))} cmp))]))
+
+(pdefine: (e r) (fold [f : ((cons number e) r -> r)] [b : r] [a : (priority-queue e)]) : r
+	  (heap:fold f b (#{heap :: ((priority-queue e) -> (pqh e))} a)))
+
+
+;; "bug" found - handling of empty heaps
+(pdefine: (a) (find-min [pq : (priority-queue a)]) : a 
+	  (let ([h (heap pq)])
+	    (if (heap:heap-node? h)
+		(elm (heap:find-min h))
+		(error "priority queue empty"))))
+
+(pdefine: (a) (find-min-priority [pq : (priority-queue a)]) : number
+	  (let ([h (heap pq)])
+	    (if (heap:heap-node? h)
+		(pri (heap:find-min h))
+		(error "priority queue empty"))))
+
+(pdefine: (a) (insert [x : a] [p : number] [pq : (priority-queue a)]) : (priority-queue a)
+	  (make (heap:insert (cons p x) (heap pq))))
+
+;; FIXME -- too many annotations needed on cons
+(pdefine: (a) (insert* [xs : (list-of a)] [ps : (list-of number)] [pq : (priority-queue a)]) : (priority-queue a)
+          (make (heap:insert* (map #{cons @ number a} ps xs) (heap pq))))
+
+(pdefine: (a) (delete-min [pq : (priority-queue a)]) : (priority-queue a)
+	  (let ([h (heap pq)])
+	    (if (heap:heap-node? h)
+		(make (heap:delete-min h))
+		(error "priority queue empty"))))
+
+
+(pdefine: (a) (size [pq : (priority-queue a)]) : number
+	  (heap:size (heap pq)))
+
+(pdefine: (a) (union [pq1 : (priority-queue a)] [pq2 : (priority-queue a)]) : (priority-queue a)
+	  (make (heap:union (heap pq1) (heap pq2))))
+
+
+#;(require "signatures/priority-queue-signature.scm")
+#;(provide-priority-queue)
+

collects/typed-scheme/typecheck/tc-expr-unit.rkt

@@ -49,7 +49,8 @@
     [(~var i (3d inexact-real?)) -Flonum]
     [(~var i (3d real?)) -Real]
     ;; a complex number can't have an inexact imaginary part and an exact real part
-    [(~var i (3d (conjoin number? (lambda (x) (inexact-real? (imag-part x))))))
+    [(~var i (3d (conjoin number? (lambda (x) (and (inexact-real? (imag-part x))
+                                                   (inexact-real? (real-part x)))))))
      -InexactComplex]
     [(~var i (3d number?)) -Number]
     [i:str -String]