Add typed/pict which exports part of pict

Does not cover all of the bindings yet, but it
should just be a SMOP after the last extra-env-lang
feature additions.

pkgs/typed-racket-pkgs/typed-racket-doc/typed-racket/scribblings/reference/libraries.scrbl

@@ -67,6 +67,7 @@ The following libraries are included with Typed Racket in the
 @defmodule/incl[typed/net/smtp]
 @defmodule/incl[typed/net/uri-codec]
 @defmodule/incl[typed/net/url]
+@defmodule/incl[typed/pict]
 @defmodule/incl[typed/rackunit]
 @defmodule/incl[typed/srfi/14]
 @defmodule/incl[typed/syntax/stx]

pkgs/typed-racket-pkgs/typed-racket-more/info.rkt

@@ -9,7 +9,8 @@
                "rackunit-lib"
                "rackunit-gui"
                "typed-racket-lib"
-               "gui-lib"))
+               "gui-lib"
+               "pict-lib"))
 
 (define pkg-desc "Types for various libraries")
 

pkgs/typed-racket-pkgs/typed-racket-more/typed/pict.rkt

@@ -0,0 +1,154 @@
+#lang s-exp typed-racket/base-env/extra-env-lang
+
+(require pict
+         (for-syntax (only-in typed-racket/rep/type-rep
+                              make-Name
+                              make-Union)))
+
+(begin-for-syntax
+ (define -pict (make-Name #'pict))
+ (define -pict-path
+   (make-Union (list (-val #f) -pict (-lst -pict))))
+ (define -child (make-Name #'child))
+ (define -pin-arrow-line
+   (->key -Real
+          -pict
+          -pict-path
+          (-> -pict -pict-path (-values (list -Real -Real)))
+          -pict-path
+          (-> -pict -pict-path (-values (list -Real -Real)))
+          #:start-angle (-opt -Real) #f
+          #:end-angle (-opt -Real) #f
+          #:start-pull -Real #f
+          #:end-pull -Real #f
+          #:line-width (-opt -Real) #f
+          ;; FIXME: color%
+          #:color (-opt (Un -String)) #f
+          #:alpha -Real #f
+          #:style (one-of/c 'transparent 'solid 'xor 'hilite
+                            'dot 'long-dash 'short-dash 'dot-dash
+                            'xor-dot 'xor-long-dash 'xor-short-dash
+                            'xor-dot-dash)
+                  #f
+          #:under? Univ #f
+          #:solid? Univ #f
+          #:hide-arrowhead? Univ #f
+          -pict))
+ (define -pict-finder
+   (-> -pict -pict-path (-values (list -Real -Real)))))
+
+(type-environment
+ [#:struct pict ([draw : Univ]
+                 [width : -Real]
+                 [height : -Real]
+                 [ascent : -Real]
+                 [children : (-lst -child)]
+                 [panbox : Univ]
+                 [last : -pict-path])
+           #:extra-constructor-name make-pict]
+ [#:struct child ([pict : -pict]
+                  [dx : -Real]
+                  [dy : -Real]
+                  [sx : -Real]
+                  [sy : -Real]
+                  [sxy : -Real]
+                  [syx : -Real])
+           #:extra-constructor-name make-child]
+
+ ;; dc
+ [blank (cl->* (-> -pict)
+               (-> -Real -pict)
+               (-> -Real -Real -pict)
+               (-> -Real -Real -Real -pict)
+               (-> -Real -Real -Real -Real -pict))]
+ ;; text
+ [hline (->key -Real -Real #:segment (-opt -Real) #f -pict)]
+ [vline (->key -Real -Real #:segment (-opt -Real) #f -pict)]
+ [frame (->key -pict
+               #:segment (-opt -Real) #f
+               ;; FIXME: add color% with class support
+               #:color (-opt -String) #f
+               #:width (-opt -Real) #f
+               -pict)]
+ [ellipse (-> -Real -Real -pict)]
+ [circle (-> -Real -pict)]
+ [filled-ellipse
+  (->key -Real -Real #:draw-border? Univ #f -pict)]
+ [disk
+  (->key -Real #:draw-border? Univ #f -pict)]
+ [rectangle (-> -Real -Real -pict)]
+ [filled-rectangle
+  (->key -Real -Real #:draw-border? Univ #f -pict)]
+ [rounded-rectangle
+  (->optkey -Real -Real [-Real] #:angle -Real #f -pict)]
+ [filled-rounded-rectangle
+  (->optkey -Real -Real [-Real]
+            #:angle -Real #f
+            #:draw-border? Univ #f
+            -pict)]
+ ;; FIXME: add bitmap% and image-snip%
+ [bitmap (-> (Un -Pathlike) -pict)]
+ [arrow (-> -Real -Real -pict)]
+ [arrowhead (-> -Real -Real -pict)]
+ [pip-line (-> -Real -Real -Real -pict)]
+ [pip-arrow-line (-> -Real -Real -Real -pict)]
+ [pip-arrows-line (-> -Real -Real -Real -pict)]
+ [pin-line
+  (->key -pict
+         -pict-path
+         (-> -pict -pict-path (-values (list -Real -Real)))
+         -pict-path
+         (-> -pict -pict-path (-values (list -Real -Real)))
+         #:start-angle (-opt -Real) #f
+         #:end-angle (-opt -Real) #f
+         #:start-pull -Real #f
+         #:end-pull -Real #f
+         #:line-width (-opt -Real) #f
+         ;; FIXME: color%
+         #:color (-opt (Un -String)) #f
+         #:alpha -Real #f
+         #:style (one-of/c 'transparent 'solid 'xor 'hilite
+                           'dot 'long-dash 'short-dash 'dot-dash
+                           'xor-dot 'xor-long-dash 'xor-short-dash
+                           'xor-dot-dash)
+                 #f
+         #:under? Univ #f
+         -pict)]
+ [pin-arrow-line -pin-arrow-line]
+ [pin-arrows-line -pin-arrow-line]
+ [bitmap-draft-mode (-Param Univ Univ)]
+
+ ;; 6 Pict Fingers
+ [lt-find -pict-finder]
+ [ltl-find -pict-finder]
+ [lc-find -pict-finder]
+ [lbl-find -pict-finder]
+ [lb-find -pict-finder]
+ [ct-find -pict-finder]
+ [ctl-find -pict-finder]
+ [cbl-find -pict-finder]
+ [cb-find -pict-finder]
+ [rt-find -pict-finder]
+ [rtl-find -pict-finder]
+ [rc-find -pict-finder]
+ [rbl-find -pict-finder]
+ [rb-find -pict-finder]
+ [pict-path? (make-pred-ty -pict-path)]
+ [launder (-> -pict -pict)]
+
+ ;; 7.1 Dingbats
+ ;; FIXME: color% for many of these
+ [cloud (->opt -Real -Real [-String] -pict)]
+ [file-icon (->opt -Real -Real -String [Univ] -pict)]
+ [standard-fish
+  (->key -Real -Real
+         #:direction (one-of/c 'left 'right) #f
+         #:color -String #f
+         #:eye-color (-opt -String) #f
+         #:open-mouth (Un -Boolean -Real) #f
+         -pict)]
+ [jack-o-lantern (->opt -Real [-String -String] -pict)]
+ [angel-wing (-> -Real -Real Univ -pict)]
+ [desktop-machine (->opt -Real [(-lst (one-of/c 'plt 'binary 'devil))] -pict)]
+ ;; thermometer
+ )

pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/succeed/pict.rkt

@@ -0,0 +1,16 @@
+#lang typed/racket
+
+;; Test typed/pict
+
+(require typed/pict)
+
+(pict-children (blank 50 50))
+(hline 1 5)
+(vline 1 5)
+(frame (circle 5) #:segment 2)
+
+(define hl (hline 1 5))
+(define-values (x y) (lt-find hl hl))
+
+(standard-fish 40 20 #:direction 'left #:color "olive")
+