DrRacket Screenshot and Window Capture

screenshot.rkt

#lang racket
;;;
;;; This library provides functions to:
;;;     1. Take a screenshot of an entire screen
;;;     2. Get a list of all windows, window ids and window names
;;;     3. Capture a single window as an image.
;;;     4. Examples: Recreation of the widget gallery.
;;;

;;; Notes: The combo-field and the text field misses text
;;;        visible on the gallery in the docs (gtk). Why?

(provide main-display-id
         number-of-active-displays
         get-active-display-ids
         screenshot
         all-window-ids
         all-window-infos
         window-info->window-name
         window-info->window-id
         capture-window
         capture-window-with-name)

(require ffi/unsafe
         ffi/unsafe/objc
         ffi/unsafe/define
         mred/private/wx/cocoa/image
         mred/private/wx/cocoa/types)

;;; One system library is needed:
(define quartz-lib 
  (ffi-lib "/System/Library/Frameworks/Quartz.framework/Versions/Current/Quartz"))

(define-ffi-definer define-quartz quartz-lib)

;;;
;;; DISPLAYS
;;;

; Each display attached to the computer has a DisplayID.
; We need the id of the display, we want to take a screenshot of.
; In most cases we want a screenshot of the main display.

; An id is represented as an unsigned 32 bit integer.
(define _CGDirectDisplayID _uint32)
; Error codes are reprented as a signed 32 bit integer.
(define _CGError _int32)

; This returns the display id of the main display
(define-quartz CGMainDisplayID (_fun -> _CGDirectDisplayID))

; main-display-id : -> integer
;    return the display id of the main display
(define (main-display-id)
  (CGMainDisplayID))

; On computers with more than one display, we need a list
; of display ids for the active displays.

; If activeDspys is passed NULL, then the dspyCount is set 
; to the number of active displays. 
; Otherwise the array pointed to by activeDspys will be filled 
; with the active display ids.
(define-quartz CGGetActiveDisplayList
  (_fun (maxDisplays : _uint32)
        (activeDspys : (_or-null (_ptr io _CGDirectDisplayID)))
        (dspyCount   : (_ptr io _uint32))
        -> 
        (error       : _CGError)
        ->
        (values error activeDspys dspyCount)))

; number-of-active-displays : -> integer
;    return the number of active displays
(define (number-of-active-displays)
  (define-values (error active dspyCount)
    (CGGetActiveDisplayList 0 #f 0))
  dspyCount)

; get-active-display-ids : -> (list integers)
;    return list of active displays ids
(define (get-active-display-ids)
  ; get the number of active displays
  (define n (number-of-active-displays))
  ; allocate an array of n display ids.
  (define activeDspys (malloc n _CGDirectDisplayID))  
  (memset activeDspys 0 (* n (ctype-sizeof _CGDirectDisplayID)))
  ; get the active displays
  (define-values (error active dspyCount)
    (CGGetActiveDisplayList n activeDspys 0))  
  ; return the display ids a list
  (for/list ([i (in-range dspyCount)])
    (ptr-ref activeDspys _CGDirectDisplayID i)))
;;;
;;; IMAGES
;;; 

; We need to deal with two types of images: CGImage and NSImage.
(define _CGImageRef (_cpointer 'CGImageRef))

; CoreGraphics is a C library, so CGImage is simple a C struct.
; NSImage however is from Cocoa, an Object C library, and
; is therefore an Object C class.
(import-class NSImage)

; DrRacket has support for converting an NSImage
; into a bitmap. To turn an CSImage into a bitmap,
; we first convert it into an NSImage.

(define (CGImage->NSImage cgimage)
  ; convert the CGimage to an NSImage
  (tell (tell NSImage alloc) 
        initWithCGImage: #:type _CGImageRef cgimage 
        size: #:type _NSSize (make-NSSize 0 0)))

(define (NSImage->bitmap nsimage)
  (image->bitmap nsimage))

(define (CGImage->bitmap cgimage)
  (NSImage->bitmap 
   (CGImage->NSImage cgimage)))

;;; SCREENSHOT OF DISPLAY

; This takes a screenshot of the display.
(define-quartz CGDisplayCreateImage
  (_fun _CGDirectDisplayID -> _CGImageRef))

; screenshot : integer -> bitmap%
(define (screenshot [display-id (main-display-id)])
  ; take a screenshot and convert it into a bitmap%
  (CGImage->bitmap
   (CGDisplayCreateImage display-id)))

;;;
;;; WINDOW CAPTURE
;;;

; The functions dealing with windows uses
; arrays and dictionaris.

;;; Arrays

; CF (CoreFoundation) has arrays.
(define _CFArrayRef (_cpointer 'CFArrayRef))
(define _CFIndex _long)

(define-quartz CFArrayGetValueAtIndex
  (_fun _CFArrayRef _CFIndex -> _pointer))

(define-quartz CFArrayGetCount
  (_fun _CFArrayRef -> _CFIndex))

(define (cfarray-length arr)
  (CFArrayGetCount arr))

(define (cfarray-get array idx)
  ; Retrieves a value at a given index.
  (CFArrayGetValueAtIndex array idx))

; Arrays of strings:
(define _CFStringRef (_cpointer 'CFStringRef))
(define _ArrayOfCFStringRef (_cpointer _CFStringRef))

;;; Dictionaries

; The libraries normally accept both CFString and NSString.

(define _CFDictionaryRef (_cpointer 'CFDictionaryRef))

; Get the number of keys in a dictionary:
(define-quartz CFDictionaryGetCount
  (_fun _CFDictionaryRef -> _CFIndex))

; Get string value from string key.
(define-quartz CFDictionaryGetValue
  (_fun _CFDictionaryRef _NSString -> (_or-null _NSString)))

; Get dictionary value from string key.
(define CFDictionaryGetValue_CFDictionaryRef
  (get-ffi-obj "CFDictionaryGetValue" quartz-lib
               (_fun _CFDictionaryRef _NSString -> _CFDictionaryRef)))

(define _CFNumberRef (_cpointer 'CFNumberRef))
(define CFDictionaryGetValue_CFNumberRef
  (get-ffi-obj "CFDictionaryGetValue" quartz-lib
               (_fun _CFDictionaryRef _NSString -> _CFNumberRef)))


;;; Numbers

; Numbers can not be stored directly as values in dictionaries.
; They are therefore wrapped in a CFNumber. We only need
; _int64 here.
(define _CFNumberType _uint32)
(define kCFNumberSInt64Type 4)

(define-quartz CFNumberGetValue
  (_fun _CFNumberRef _CFNumberType (val : (_ptr o _int64)) -> _bool -> val))
(define (CFNumber->integer c)
  (CFNumberGetValue c kCFNumberSInt64Type))

;;; Points, sizes and rectangles.

; struct CGPoint { CGFloat x; CGFloat y; };
(define-cstruct _CGPoint ([x _CGFloat] [y _CGFloat]))
; struct CGSize { CGFloat width; CGFloat height; };
(define-cstruct _CGSize ([width _CGFloat] [height _CGFloat]))
; struct CGRect { CGPoint origin; CGSize size; };
(define-cstruct _CGRect ([origin _CGPoint] [size _CGSize]))

(define CGRectNull 
  (make-CGRect (make-CGPoint 0.0 0.0)
               (make-CGSize  0.0 0.0)))

;;; Windows 

; Each window has an window id.
(define _CGWindowID _uint32)

; a guaranteed invalid WindowId
(define kCGNullWindowID 0)

; The following options can be used with functions
; that work with a list of windows.
(define _CGWindowListOption _uint32)
(define (<< a b) (arithmetic-shift a b))
(define kCGWindowListOptionAll 0)
(define kCGWindowListOptionOnScreenOnly         (<< 1 0))
(define kCGWindowListOptionOnScreenAboveWindow  (<< 1 1))
(define kCGWindowListOptionOnScreenBelowWindow  (<< 1 2))
(define kCGWindowListOptionIncludingWindow      (<< 1 3))
(define kCGWindowListExcludeDesktopElements     (<< 1 4))

; Returns an array of CFDictionaryRefs. One dictionary
; for each window. The options and the relativeToWindow id
; determine which windows are included in the list.
(define-quartz CGWindowListCopyWindowInfo
  (_fun _CGWindowListOption _CGWindowID -> _CFArrayRef))

; Returns an array of CGWindowID. The options and the 
; relativeToWindow id determine which windows are 
; included in the list. 
(define-quartz CGWindowListCreate
  (_fun _CGWindowListOption _CGWindowID -> _CFArrayRef))

(define (window-ids options relative-id)
  ; return a list of ids
  (when (list? options)
    (set! options (apply bitwise-ior options)))
  (define id-cfarray
    (CGWindowListCreate options relative-id))
  (if (null? id-cfarray)
      '()
      (for/list ([i (in-range (cfarray-length id-cfarray))])
        (cast (cfarray-get id-cfarray i) _pointer _uint64))))

(define (all-window-ids)
  ; return all available window ids
  (window-ids kCGWindowListOptionAll kCGNullWindowID))

(define (window-infos options relative-id)
  ; return a list of infos (dictionaries)
  (when (list? options)
    (set! options (apply bitwise-ior options)))
  (define info-cfarray
    (CGWindowListCopyWindowInfo options relative-id))
  (if (null? info-cfarray)
      '()
      (for/list ([i (in-range (cfarray-length info-cfarray))])
        (cast (cfarray-get info-cfarray i) _pointer _CFDictionaryRef))))

(define (all-window-infos)
  (window-infos kCGWindowListOptionAll kCGNullWindowID))

(define (window-info->window-id info)
  (CFNumber->integer
   (CFDictionaryGetValue_CFNumberRef 
    info "kCGWindowNumber")))

(define (window-info->window-name info)
  (CFDictionaryGetValue info "kCGWindowName"))

(define (window-info->bounds info)
  (define rect 
    (make-CGRect (make-CGPoint 0 0) (make-CGSize 50 150)))
  (define bounds 
    (CFDictionaryGetValue_CFDictionaryRef info "kCGWindowBounds"))
  (CGRectMakeWithDictionaryRepresentation bounds rect))


; (define (get-window-id arr idx)
;    ; get WindowID from a CFArray og ids.
;    (cast (cfarray-get arr idx) _pointer _uint64))

;;; Window Capture

; The window capture options are:
(define _CGWindowImageOption _uint32)
(define kCGWindowImageDefault             0)
(define kCGWindowImageBoundsIgnoreFraming (<< 1 0))
(define kCGWindowImageShouldBeOpaque      (<< 1 1))
(define kCGWindowImageOnlyShadows         (<< 1 2))

; Capture a window:
(define-quartz CGWindowListCreateImage
  (_fun _CGRect              ; screenbounds                     
        _CGWindowListOption  ; windowOption
        _CGWindowID          ; windowId
        _CGWindowImageOption ; imageOption
        ->
        _CGImageRef))

; capture-window : CGWindowID CGRect -> bitmap%
(define (capture-window window-id bounds)
  (CGImage->bitmap
   (CGWindowListCreateImage 
    bounds
    (bitwise-ior
     kCGWindowListOptionAll
     ; kCGWindowListOptionOnScreenOnly
     ; kCGWindowListExcludeDesktopElements
     kCGWindowListOptionIncludingWindow
     )
    window-id
    (bitwise-ior
     kCGWindowImageDefault
     ; kCGWindowImageBoundsIgnoreFraming
     kCGWindowImageShouldBeOpaque
     ; kCGWindowImageOnlyShadows
     ))))


; bool CGRectMakeWithDictionaryRepresentation(
;    CFDictionaryRef dict, CGRect *rect );
(define-quartz CGRectMakeWithDictionaryRepresentation
  (_fun _CFDictionaryRef (r : (_ptr io _CGRect)) -> _bool -> (values r)))

; capture-window-with-name : pattern -> #f or bitmap
;    Capture the first window with a name 
;    mathing the pattern.
(define (capture-window-with-name rx)
  (define (name-matches? name)
    (and name (regexp-match rx name)))
  (for/first 
      ([dict (window-infos (list kCGWindowListOptionOnScreenOnly
                                 kCGWindowListExcludeDesktopElements
                                 kCGWindowListOptionIncludingWindow)
                           kCGNullWindowID)]
       #:when (name-matches? (window-info->window-name dict)))
    (define bounds (window-info->bounds dict))
    (define id     (window-info->window-id dict))
    (capture-window id bounds)))

;;; EXAMPLES

(require slideshow/pict)

; capture a single window
(scale (bitmap (capture-window-with-name "DrRacket")) 1/4)
; (capture-window-with-name "bash")
; (capture-window-with-name "Regular")


;;; Showcase GUI elements
; https://github.com/plt/racket/blob/master/collects/scribblings/gui/widget-gallery.scrbl

(require (except-in racket/gui ->))

(define (capture-showcase make [name "widget"] #:hmult (hmult 1))
  (define frame (new frame% [label name]))
  (define panel (new panel% [parent frame]))
  (define showcase-panel
    (new horizontal-panel%
         [parent panel] [alignment '(center center)]
         [min-width 300] [min-height (* hmult 75)]
         [style '(border)] [border 20]))
  (make showcase-panel)
  (send frame refresh)  
  (send frame show #t)
  (send frame refresh)
  ; (sleep 1)
  (begin0
    (capture-window-with-name name)
    (send frame show #f)))

(define-syntax (showcase stx)
  (syntax-case stx ()
    [(_ title hmult panel expr ...)
     (identifier? #'panel)
     #'(capture-showcase (lambda (panel) expr ...) title #:hmult hmult)]
    [(_ title panel expr ...)
     (raise-syntax-error 'showcase 
                         "expected identifier"
                         stx #'panel)]
    [_
     (raise-syntax-error 'showcase 
                         "expected (showcase <expr> <identifier> <expr> ...)"
                         stx)]))

(showcase "button%" 1 panel
          (new button%
               (parent panel)
               (label "Button")))

(showcase "check-box%" 1 panel
          (new check-box%
               (parent panel)
               (label "Check Box")
               (value #t)))

(showcase "check-box%" 1 panel
          (new check-box%
               (parent panel)
               (label "Check Box")
               (value #f)))


(showcase "choice%" 1 panel
          (new choice%
               (label "Choice")
               (parent panel)
               (choices (list "Item 0"))))

(showcase "combo-field%" 1 panel
          (new combo-field%
               (label "Combo")
               (parent panel)
               (choices (list "Field"))
               (init-value "Field")))

(showcase "editor-canvas%" 2 panel
          (define editor-canvas
            (new editor-canvas%
                 (parent panel)
                 (label "Editor Canvas")))
          (define text (new text%))
          (send text insert "Editor Canvas")
          (send editor-canvas set-editor text)
          )


(showcase "gauge" 1 panel
          (define gauge
            (new gauge%
               (label "Gauge")
               (parent panel)
               (range 100)))
          (send gauge set-value 42))

(showcase "group-box-panel" 1 panel
          (new group-box-panel%
               (parent panel)
               (label "Group Box Panel")))

(showcase "list-box" 1 panel
          (new list-box%
               (label "List Box")
               (parent (new horizontal-panel%
                            (parent panel)
                            (style (list 'border))))
               (choices (list "Item 0"
                              "Item 1"
                              "Item 2"))
               (style (list 'single
                            'column-headers))
               (columns (list "First Column"))))

#;(showcase "menu-bar" 1 panel
          (define menu-bar 
            (new menu-bar%
                 (parent frame)))
          (new menu%
               (label "&File")
               (parent menu-bar))
          (new menu%
               (label "&Edit")
               (parent menu-bar))
          (new menu%
               (label "&Help")
               (parent menu-bar))
          )

(showcase "message" 1 panel
          (new message%
               (parent panel)
               (label "Message")))

(showcase "panel" 2 panel
          (define a-panel 
            (new panel%
                 (parent panel)
                 (style (list 'border))))
          (new message%
               (parent a-panel)
               (label "Panel")))

(showcase "radio-box" 1 panel
          (new radio-box%
               (label "Radio Box")
               (parent panel)
               (choices (list "Button 0"
                              "Button 1"
                              "Button 2"))))

(showcase "slider" 1 panel
          (new slider%
               (label "Slider")
               (parent panel)
               (min-value 0)
               (max-value 100)
               (init-value 42)))

(showcase "tab-panel" 1 panel
          (new tab-panel%
               (parent panel)
               (choices (list "Tab 0"
                              "Tab 1"
                              "Tab 2"))))

(showcase "text-field" 2 panel
          (new text-field%
               (label "Text")
               (parent panel)
               (init-value "Field")))