GraphicsForHTML5.ns

Newspeak3
'Root'
class GraphicsForHTML5 usingPlatform: p (* :exemplar: platform graphics *) = (
(*
Core graphics support for Newspeak.

Copyright Google Inc. 2015 - 2017
*)
  |
private js = p js.
(* Should be a lazy slot*)
document_slot 
|) (
public class Canvas width: w height: h = (
    |
	private alien ::= document createElement: 'canvas'.
    |
	alien at: 'width' put: w.
	alien at: 'height' put: h.
	(alien at: 'style') at: 'position' put: 'relative'.
) (
public context = (
	^Context on: (alien getContext: '2d')
)
public mouseDownAction: onMouseDown <[:Point]> = (
	alien addEventListener: 'mousedown' action:
		[:event | onMouseDown value: (Point x: (event at: 'offsetX') y: (event at: 'offsetY')). nil].
)
public mouseMovedAction: onMouseMoved <[:Point]> = (
	alien addEventListener: 'mousemove' action:
		[:event | onMouseMoved value: (Point x: (event at: 'offsetX') y: (event at: 'offsetY')). nil].
)
) : (
)
public class Color scaledR: r g: g b: b a: a = (|
public red <Integer> = r.
public green <Integer> = g.
public blue <Integer> = b.
public alpha <Integer> = a.
|) (
public applyToStyle: style = (
	style setProperty: 'background-color' to: self asCSSString
)
public asCSSString = (
	^'rgba(', red printString, ',', green printString, ',', blue printString, ',', alpha printString, ')'
)
public isKindOfColor ^ <Boolean> = (
  ^true
)
) : (
public red: brightness = (
	^self scaledR: brightness g: 0 b: 0 a: 255
)
public black = (
	^self scaledR: 0 g: 0 b: 0 a: 255
)
public blue = (
	^self scaledR: 0 g: 0 b: 255 a: 255
)
public blue: brightness = (
	^self scaledR: 0 g: 0 b: brightness a: 255
)
public gray = (
	^self r: 0.5 g: 0.5 b: 0.5
)
public gray: brightness = (
	^self r: brightness g: brightness b: brightness
)
public green = (
	^self r: 0.0 g: 1.0 b: 0.0
)
public h: hue s: saturation v: brightness = (
	| s v hf i f p q t |
	s:: (saturation asFloat max: 0.0) min: 1.0.
	v:: (brightness asFloat max: 0.0) min: 1.0.

	(* zero saturation yields gray with the given brightness *)
	s = 0.0 ifTrue: [ ^self r: v g: v b: v ].

	hf:: hue asFloat.
	(hf < 0.0 or: [hf >= 360.0])
		ifTrue: [hf:: hf \\ 360].
	hf:: hf / 60.0.
	i:: hf asInteger. (* integer part of hue *)
	f:: hf - i. (* hf fractionPart. *)  (* fractional part of hue *)
	p:: (1.0 - s) * v.
	q:: (1.0 - (s * f)) * v.
	t:: (1.0 - (s * (1.0 - f))) * v.

	0 = i ifTrue: [ ^self r: v g: t b: p ].
	1 = i ifTrue: [ ^self r: q g: v b: p ].
	2 = i ifTrue: [ ^self r: p g: v b: t ].
	3 = i ifTrue: [ ^self r: p g: q b: v ].
	4 = i ifTrue: [ ^self r: t g: p b: v ].
	5 = i ifTrue: [ ^self r: v g: p b: q ].

	Error signal: 'implementation error'.
)
public magenta = (
	^self r: 139 g: 0 b: 139 a: 255
)
public orange = (
	^self scaledR: 255 g: 165 b: 0 a: 255
)
public r: r g: g b: b = (
	^self scaledR: (r * 255) floor g: (g * 255) floor b: (b * 255) floor a: 255
)
public r: r g: g b: b a: a = (
	^self scaledR: (r * 255) floor g: (g * 255) floor b: (b * 255) floor a: a
)
public red = (
    ^self r: 1.0 g: 0.0 b: 0.0
)
public yellow = (
    ^self r: 1.0 g: 1.0 b: 0.0
)
public white = (
    ^self r: 1.0 g: 1.0 b: 1.0
)
)
public class Context on: a = (|
alien = a.
|) (
public arcAt: center radius: radius from: startAngle to: stopAngle = (
	alien arc: center x with: center y with: radius with: startAngle with: stopAngle
)
public beginPath = (
	alien beginPath.
)
public fill = (
	alien fill.
)
public fillStyle: c <Color> = (
	alien at: 'fillStyle' put: c asCSSString.
)
public fillText: string at: p = (
	alien fillText: string with: p x with: p y
)
public lineTo: p = (
	alien lineTo: p x with: p y
)
public moveTo: p = (
	alien moveTo: p x with: p y
)
public rectangle: r = (
	alien rect: r origin x with: r origin y with: r extent x with: r extent y
)
public stroke = (
	alien stroke.
)
public strokeStyle: c <Color> = (
	alien at: 'strokeStyle' put: c asCSSString
)
) : (
)
public class Point x: xCoord y: yCoord = (|
public x <Number> = xCoord.
public y <Number> = yCoord.
|) (
public = other <Object> ^<Boolean> = (
	^other isPoint and: [x = other x and: [y = other y]]
)
public corner: corner <Point> ^<Rectangle> = (
	^Rectangle origin: self corner: corner
)
public extent: extent <Point> ^<Rectangle> = (
	^Rectangle origin: self extent: extent
)
public hash ^<Integer> = (
	^x hash bitXor: y hash
)
public isPoint ^<Boolean> = (
	^true
)
public printString ^<String> = (
	^x printString, ' @ ', y printString
)
public r ^<Number> = (
	^((x*x) + (y*y)) sqrt
)
public theta ^<Number> = (
	Error signal: 'Unimplemented'
)
) : (
public r: r <Number> theta: theta <Number> ^<Point> = (
	^self x: r * theta cos y: r * theta sin
)
public zero ^<Point> = (
	^self x: 0 y: 0
)
)
public class Rectangle origin: o corner: c = (|
public origin <Point> = o.
public corner <Point> = c.
|) (
public = other ^<Boolean> = (
	^other isRectangle and: [origin = other origin and: [corner = other corner]]
)
public center = (
	^Point x: origin x + ((corner x - origin x) / 2) y: origin y + ((corner y - origin y) / 2)
)
public containsPoint: p = (
	^((origin x <= p x
		and: [origin y <= p y])
		and: [corner x >= p x])
		and: [corner y >= p y]
)
public extent = (
	^Point x: corner x - origin x y: corner y - origin y
)
public hash ^<Integer> = (
	^origin hash bitXor: corner hash
)
public insetBy: delta = (
	^Rectangle
		origin: (Point x: origin x + delta x y: origin y + delta y)
		corner: (Point x: corner x - delta x y: corner y - delta y)
)
public isRectangle ^<Boolean> = (
	^true
)
public printString ^<String> = (
	^'Rectangle origin: ', origin printString, ' corner: ', corner printString
)
) : (
public origin: o <Point> extent: e <Point> ^<Rectangle> = (
	^self origin: o corner: (Point x: o x + e x y: o y + e y)
)
)
document = (
(*  Making #document lazy allows us to use the C version of Psoup to generate vfuel files from platforms that include this module.  Since one cannot actually call JS from the C based serializer, we want to delay accessing the JS module's properties until we are actually running. *)
  document_slot isNil ifTrue: [document_slot:: js global at: 'document'].
  ^document_slot
)
) : (
)