Skip to content

Instantly share code, notes, and snippets.

@soegaard
Created December 5, 2012 23:32
Show Gist options
  • Save soegaard/019d30cfed891b1899b9 to your computer and use it in GitHub Desktop.
Save soegaard/019d30cfed891b1899b9 to your computer and use it in GitHub Desktop.
DrRacket Screenshot and Window Capture
#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")))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment