[racket-dev] Pre-Release Checklist for v6.0, Second Call

We really shouldn't ship until this memory leak is fixed (which I just 
reported):

     http://bugs.racket-lang.org/query/?cmd=view&pr=14264

It's making writing substantial programs very difficult, especially in 
Typed Racket, which seems to be affected more.

It's possible there's a weird interaction with Ubuntu 13.10, which I 
upgraded to last week, but I don't know what it could be. Or I may just 
not have noticed before. (I haven't been coding much recently.)

Neil ⊥

-------------- next part --------------
#lang racket

(require (only-in typed/racket/base index?))

(define (emit v)
  (printf "~a~n" v))

;(: multi-dag-add-edge (All (T R) ((Multi-Dag T R) T R T -> (Multi-Dag T R))))
(define (multi-dag-add-edge h src r dst)
  (define edges (hash-ref h src (λ () (make-immutable-hash))))
  (define dsts (hash-ref edges r (λ () (set))))
  (hash-set h src (hash-set edges r (set-add dsts dst))))

;; ===================================================================================================

;(: set-union* (All (A) ((Setof (Setof A)) -> (Setof A))))
(define (set-union* s)
  (define ss (set->list s))
  (cond [(empty? ss)  (set)]
        [else  (apply set-union (first ss) (rest ss))]))

;(: set-image (All (A B) ((A -> B) (Setof A) -> (Setof B))))
(define (set-image f s)
  (list->set (set-map s f)))

;(: set-bind (All (A B) ((Setof A) (A -> (Setof B)) -> (Setof B))))
(define (set-bind A f)
  (set-union* (set-image f A)))

;; ===================================================================================================

(struct Relation (forward backward)
  #:transparent
  #:property prop:custom-print-quotable 'never
  #:property prop:custom-write
  (λ (r out mode)
    (write-string (symbol->string (Relation-forward r)) out)))

(define-syntax-rule (define-relation name1 name2)
  (begin
    (define name1 (Relation 'name1 'name2))
    (define name2 (Relation 'name2 'name1))))

(define-relation holding held-by)
(define-relation inside outside)
(define-relation north south)
(define-relation east west)
(define-relation up down)

;(: relation-reverse (Relation -> Relation))
(define (relation-reverse r)
  (Relation (Relation-backward r)
            (Relation-forward r)))

;; ===================================================================================================

(struct Edge (fst rel snd) #:transparent)

(struct Action-Type () #:transparent)
(struct Look Action-Type () #:transparent)

(struct Describe Action-Type (parent relation entity) #:transparent)

(struct Action-Dest (relation entity) #:transparent)
(struct Action-Path (src dsts) #:transparent)

(struct Init-Action (type src) #:transparent)
(struct Received-Action (type path) #:transparent)

;(define-type Action (U Init-Action Received-Action))

;(: action-path-entities (Action-Path -> (Listof Pointer)))
(define (action-path-entities p)
  (match-define (Action-Path src dsts) p)
  (cons src (reverse (map Action-Dest-entity dsts))))

;(: action-path-relations (Action-Path -> (Listof Relation)))
(define (action-path-relations p)
  (reverse (map Action-Dest-relation (Action-Path-dsts p))))

;(: action-entities (Action -> (Listof Pointer)))
(define (action-entities act)
  (match act
    [(Init-Action _ src)  (list src)]
    [(Received-Action _ path)  (action-path-entities path)]))

;(: action-last-entity (Action -> Pointer))
(define (action-last-entity act)
  (match act
    [(Init-Action type src)  src]
    [(Received-Action type (Action-Path src dsts))  (Action-Dest-entity (first dsts))]))

;(: action-push-dest (Action Relation Pointer -> Received-Action))
(define (action-push-dest act r dst)
  (match act
    [(Init-Action type src)  (Received-Action type (Action-Path src (list (Action-Dest r dst))))]
    [(Received-Action type (Action-Path src dsts))
     (Received-Action type (Action-Path src (cons (Action-Dest r dst) dsts)))]))

;(: action-pop-dest (Received-Action -> (Values Action Relation Pointer)))
(define (action-pop-dest act)
  (match-define (Received-Action type (Action-Path src dsts)) act)
  (match-let* ([(Action-Dest rel dst)  (first dsts)]
               [dsts  (rest dsts)])
    (cond [(empty? dsts)  (values (Init-Action type src) rel dst)]
          [else  (values (Received-Action type (Action-Path src dsts)) rel dst)])))

;(: action-path-reverse (Action-Path -> Action-Path))
(define (action-path-reverse p)
  (match-define (Action-Path src dsts) p)
  (define es (reverse (action-path-entities p)))
  (define rs (reverse (action-path-relations p)))
  (Action-Path
   (first es)
   (reverse (for/list ([e  (in-list (rest es))]
                       [r  (in-list rs)])
              (Action-Dest (relation-reverse r) e)))))

(struct Entity (name alts start-action receive-action properties) #:transparent)

;(: empty-property-hash (HashTable Symbol Any))
(define empty-property-hash (make-immutable-hasheq))

;; ===================================================================================================
;; The world

;(define-type Pointer Index)

;(: empty-entity-set (Setof Pointer))
(define empty-entity-set (seteq))

;(: empty-relation-hash (Out-Edges Pointer Relation))
(define empty-relation-hash (make-immutable-hash))

(struct World (next entities links actions) #:transparent)

;(: empty-world World)
(define empty-world
  (World 0
         (make-immutable-hasheq)
         (make-immutable-hasheq)
         (list)))

;(: get-entity (World Pointer -> Entity))
(define (get-entity w *o)
  (hash-ref (World-entities w) *o
            (λ () (error 'get-entity "Entity ~a does not exist" *o))))

;(: world-entities (World -> (Setof Pointer)))
(define (world-entities w)
  (list->set (hash-keys (World-entities w))))

(define-syntax-rule (define-entity-accessor name Name)
  (define name
    (λ (w *o)
      (Name (get-entity w *o)))))

(define-entity-accessor entity-name Entity-name)
(define-entity-accessor entity-alts Entity-alts)
(define-entity-accessor entity-start-action Entity-start-action)
(define-entity-accessor entity-receive-action Entity-receive-action)
(define-entity-accessor entity-properties Entity-properties)

;(: add-entity (World Entity -> (Values World Pointer)))
(define (add-entity w e)
  (match-define (World idx entities links actions) w)
  (define next-idx (+ idx 1))
  (cond [(index? next-idx)
         (values (World next-idx
                        (hash-set entities idx e)
                        links
                        actions)
                 idx)]
        [else
         (error 'add-entity "No more entity indexes")]))

;(: set-entity (World Pointer Entity -> World))
(define (set-entity w e ent)
  (match-define (World idx entities links actions) w)
  (World idx (hash-set entities e ent) links actions))

;(: remove-entity (World Pointer -> World))
(define (remove-entity w e)
  (match-define (World idx entities links actions) w)
  (World idx
         (hash-remove entities e)
         (hash-remove links e)
         actions))

;(: get-relation-hash (World Pointer -> (Out-Edges Pointer Relation)))
(define (get-relation-hash w e)
  (hash-ref (World-links w) e (λ () empty-relation-hash)))

;(: set-relation-hash (World Pointer (Out-Edges Pointer Relation) -> World))
(define (set-relation-hash w e h)
  (match-define (World idx entities links actions) w)
  (let ([links  (if (zero? (hash-count h))
                    (hash-remove links e)
                    (hash-set links e h))])
    (World idx entities links actions)))

;(: push-action (World Action -> World))
(define (push-action w act)
  (match-define (World idx entities links actions) w)
  (World idx entities links (cons act actions) #;(queue-push-left actions act)))

;(: pull-action (World -> (Values World Action)))
(define (pull-action w)
  (match-define (World idx entities links actions) w)
  (let-values ([(actions act)  (values (take actions (- (length actions) 1)) (last actions))])
    (values (World idx entities links actions) act)))

;(: has-actions? (World -> Boolean))
(define (has-actions? w)
  (not (empty? (World-actions w))))