# HG changeset patch
# User Michael Pavone <pavone@retrodev.com>
# Date 1427076632 25200
# Node ID 3edd0169311a337cf8dbacfbf1b7d6c7586a21fe
# Parent  1debeb21dd47abe268ede3b17296043bac6f1443
Add basic binding to Freetype2

diff -r 1debeb21dd47 -r 3edd0169311a modules/freetype.tp
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/modules/freetype.tp	Sun Mar 22 19:10:32 2015 -0700
@@ -0,0 +1,315 @@
+{
+	_helper <- #{
+		includeSystemHeader: "ft2build.h"
+		includeSystemHeader: FT_FREETYPE_H
+		llMessage: newFace withVars: {
+			libOpaque <- cpointer ptr
+			opath <- object ptr
+			oindex <- object ptr
+			path <- string ptr
+			index <- obj_int32 ptr
+			faceOpaque <- cpointer ptr
+			rescode <- int32_t
+		} andCode: :libOpaque opath oindex {
+			path <- (mcall: string 1 opath) castTo: (string ptr)
+			index <- (mcall: int32 1 oindex) castTo: (obj_int32 ptr)
+			faceOpaque <- make_object: (addr_of: cpointer_meta) NULL 0
+			rescode <- FT_New_Face: (libOpaque val) (path data) (index num) ((addr_of: (faceOpaque val)) castTo: (FT_Face ptr))
+			if: rescode = 0 {
+				mcall: value 2 option faceOpaque
+			} else: {
+				mcall: none 1 option
+			}
+		}
+		
+		llMessage: getFirstChar withVars: {
+			opaque <- cpointer ptr
+			glyphIndex <- obj_uint32 ptr
+			charCode <- obj_uint32 ptr
+			makeChar <- lambda ptr
+		} andCode: :opaque makeChar {
+			glyphIndex <- make_object: (addr_of: obj_uint32_meta) NULL 0
+			charCode <- make_object: (addr_of: obj_uint32_meta) NULL 0
+			charCode num!: (FT_Get_First_Char: (opaque val) (addr_of: (glyphIndex num)))
+			ccall: makeChar 2 charCode glyphIndex
+		}
+		
+		llMessage: getNextChar withVars: {
+			opaque <- cpointer ptr
+			ocurChar <- object ptr
+			curChar <- obj_uint32 ptr
+			glyphIndex <- obj_uint32 ptr
+			charCode <- obj_uint32 ptr
+			makeChar <- lambda ptr
+		} andCode: :opaque ocurChar makeChar {
+			curChar <- (mcall: uint32 1 ocurChar) castTo: (obj_uint32 ptr)
+			glyphIndex <- make_object: (addr_of: obj_uint32_meta) NULL 0
+			charCode <- make_object: (addr_of: obj_uint32_meta) NULL 0
+			charCode num!: (FT_Get_Next_Char: (opaque val) (curChar num) (addr_of: (glyphIndex num)))
+			ccall: makeChar 2 charCode glyphIndex
+		}
+	}
+	
+	_makeSlot <- :opaque {
+		#{
+			llProperty: slot withType: FT_GlyphSlot
+			llMessage: _ptr_init withVars: {
+				opaque <- cpointer ptr
+			} andCode: :opaque {
+				slot <- opaque val
+				self
+			}
+			
+			llMessage: linearHoriAdvance withVars: {
+				intret <- obj_int32 ptr
+			} andCode: {
+				intret <- make_object: (addr_of: obj_int32_meta) NULL 0
+				intret num!: (slot linearHoriAdvance)
+				intret
+			}
+			
+			llMessage: linearVertAdvance withVars: {
+				intret <- obj_int32 ptr
+			} andCode: {
+				intret <- make_object: (addr_of: obj_int32_meta) NULL 0
+				intret num!: (slot linearVertAdvance)
+				intret
+			}
+			
+			llMessage: bitmapTop withVars: {
+				intret <- obj_int32 ptr
+			} andCode: {
+				intret <- make_object: (addr_of: obj_int32_meta) NULL 0
+				intret num!: (slot bitmap_top)
+				intret
+			}
+			
+			llMessage: bitmapLeft withVars: {
+				intret <- obj_int32 ptr
+			} andCode: {
+				intret <- make_object: (addr_of: obj_int32_meta) NULL 0
+				intret num!: (slot bitmap_left)
+				intret
+			}
+			
+			llMessage: bitmapRows withVars: {
+				uintret <- obj_uint32 ptr
+			} andCode: {
+				uintret <- make_object: (addr_of: obj_uint32_meta) NULL 0
+				uintret num!: ((addr_of: (slot bitmap)) rows)
+				uintret
+			}
+			
+			llMessage: bitmapWidth withVars: {
+				uintret <- obj_uint32 ptr
+			} andCode: {
+				uintret <- make_object: (addr_of: obj_uint32_meta) NULL 0
+				uintret num!: ((addr_of: (slot bitmap)) width)
+				uintret
+			}
+			
+			llMessage: bitmapPitch withVars: {
+				intret <- obj_int32 ptr
+			} andCode: {
+				intret <- make_object: (addr_of: obj_uint32_meta) NULL 0
+				intret num!: ((addr_of: (slot bitmap)) pitch)
+				intret
+			}
+			
+			llMessage: bitmapData withVars: {
+				opaque <- cpointer ptr
+				size <- obj_int32 ptr
+			} andCode: {
+				opaque <- make_object: (addr_of: cpointer_meta) NULL 0
+				opaque val!: ((addr_of: (slot bitmap)) buffer)
+				size <- make_object: (addr_of: obj_int32_meta) NULL 0
+				size num!: ((addr_of: (slot bitmap)) rows) * ((addr_of: (slot bitmap)) pitch)
+				mcall: fromOpaque:withSize 3 bytearray opaque size
+			}
+			
+			llMessage: renderGlyph withVars: {
+				omode <- object ptr
+				mode <- obj_uint32 ptr
+				intret <- obj_int32 ptr
+			} andCode: :omode {
+				mode <- (mcall: uint32 1 omode) castTo: (obj_uint32 ptr)
+				intret <- make_object: (addr_of: obj_int32_meta) NULL 0
+				intret num!: (FT_Render_Glyph: slot (mode num))
+				intret
+			}
+		} _ptr_init: opaque
+	}
+	
+	_makeChar <- :_charcode _glyph {
+		#{
+			charcode <- _charcode
+			glyph <- _glyph
+		}
+	}
+	_makeFace <- :opaque {
+		#{
+			llProperty: face withType: FT_Face
+			llProperty: makeSlot withType: (lambda ptr)
+			llMessage: _ptr_init withVars: {
+				opaque <- cpointer ptr
+				makeSlotLambda <- lambda ptr
+			} andCode: :opaque makeSlotLambda {
+				face <- opaque val
+				makeSlot <- makeSlotLambda
+				self
+			}
+			
+			llMessage: faceOpaque withVars: {
+				opaque <- cpointer ptr
+			} andCode: {
+				opaque <- make_object: (addr_of: cpointer_meta) NULL 0
+				opaque val!: face
+				opaque
+			}
+			
+			llMessage: setCharWidth:height:hRes:vRes withVars: {
+				ohsize <- object ptr
+				hsize <- obj_float32 ptr
+				ovsize <- object ptr
+				vsize <- obj_float32 ptr
+				ohres <- object ptr
+				hres <- obj_int32 ptr
+				ovres <- object ptr
+				vres <- obj_int32 ptr
+				intret <- obj_int32 ptr
+			} andCode: :ohsize ovsize :ohres :ovres {
+				hsize <- (mcall: f32 1 ohsize) castTo: (obj_float32 ptr)
+				vsize <- (mcall: f32 1 ovsize) castTo: (obj_float32 ptr)
+				hres <- (mcall: int32 1 ohres) castTo: (obj_int32 ptr)
+				vres <- (mcall: int32 1 ovres) castTo: (obj_int32 ptr)
+				intret <- make_object: (addr_of: obj_int32_meta) NULL 0
+				intret num!: (FT_Set_Char_Size: face (hsize num) * 64 (vsize num) * 64 (hres num) (vres num))
+				intret
+			}
+			
+			setCharSize:res <- :size :res {
+				setCharWidth: size height: size hRes: res vRes: res
+			}
+			
+			llMessage: getCharIndex withVars: {
+				ocharcode <- object ptr
+				charcode <- obj_uint32 ptr
+				uintret <- obj_uint32 ptr
+			} andCode: :ocharcode {
+				charcode <- (mcall: uint32 1 ocharcode) castTo: (obj_uint32 ptr)
+				uintret <- make_object: (addr_of: obj_uint32_meta) NULL 0
+				uintret num!: (FT_Get_Char_Index: face (charcode num))
+				uintret
+			}
+			
+			llMessage: loadGlyph:flags withVars: {
+				oindex <- object ptr
+				index <- obj_uint32 ptr
+				oflags <- object ptr
+				flags <- obj_uint32 ptr
+				intret <- obj_int32 ptr
+			} andCode: :oindex :oflags {
+				index <- (mcall: uint32 1 oindex) castTo: (obj_uint32 ptr)
+				flags <- (mcall: uint32 1 oflags) castTo: (obj_uint32 ptr)
+				intret <- make_object: (addr_of: obj_int32_meta) NULL 0
+				intret num!: (FT_Load_Glyph: face (index num) (flags num))
+				intret
+			}
+			
+			llMessage: glyphSlot withVars: {
+				opaque <- cpointer ptr
+			} andCode: {
+				opaque <- make_object: (addr_of: cpointer_meta) NULL 0
+				opaque val!: (face glyph)
+				ccall: makeSlot 1 opaque
+			}
+			
+			firstChar <- {
+				_helper getFirstChar: faceOpaque _makeChar
+			}
+			
+			nextChar <- :curChar {
+				_helper getNextChar: faceOpaque curChar _makeChar
+			}
+			
+			charmap <- {
+				d <- dict hash
+				char <- firstChar
+				d set: (char charcode) (char glyph)
+				while: { (char glyph) != 0u32 } do: {
+					char <- nextChar: (char charcode)
+					d set: (char charcode) (char glyph)
+				}
+				d
+			}
+		} _ptr_init: opaque _makeSlot
+	}
+	
+	_constant <- macro: :name cname {
+		quote: (llMessage: name withVars: {
+			uintret <- obj_uint32 ptr
+		} andCode: {
+			uintret <- make_object: (addr_of: obj_uint32_meta) NULL 0
+			uintret num!: cname
+			uintret
+		})
+	}
+	
+	_loadFlags <- #{
+		_constant: default FT_LOAD_DEFAULT
+		_constant: noScale FT_LOAD_NO_SCALE
+		_constant: noHinting FT_LOAD_NO_HINTING
+		_constant: render FT_LOAD_RENDER
+		_constant: noBitmap FT_LOAD_NO_BITMAP
+		_constant: verticalLayout FT_LOAD_VERTICAL_LAYOUT
+		_constant: forceAuthohint FT_LOAD_FORCE_AUTOHINT
+		_constant: pedantic FT_LOAD_PEDANTIC
+		_constant: noRecurse FT_LOAD_NO_RECURSE
+		_constant: ignoreTransform FT_LOAD_IGNORE_TRANSFORM
+		_constant: monochrome FT_LOAD_MONOCHROME
+		_constant: linearDesign FT_LOAD_LINEAR_DESIGN
+		_constant: noAutohint FT_LOAD_NO_AUTOHINT
+		_constant: color FT_LOAD_COLOR
+	}
+	
+	#{
+		init <- {
+			
+			#{
+				includeSystemHeader: "ft2build.h"
+				includeSystemHeader: FT_FREETYPE_H
+				llProperty: library withType: FT_Library
+				
+				llMessage: _init withVars: {
+				} andCode: {
+					FT_Init_FreeType: (addr_of: library)
+					self
+				}
+				
+				llMessage: libraryOpaque withVars: {
+					libOpaque <- cpointer ptr
+				} andCode: {
+					libOpaque <- make_object: (addr_of: cpointer_meta) NULL 0
+					libOpaque val!: library
+					libOpaque
+				}
+				
+				faceFromPath:index <- :path :index {
+					(_helper newFace: libraryOpaque path index) value: :opaque {
+						option value: (_makeFace: opaque)
+					} none: {
+						option none
+					}
+				}
+				
+				llMessage: destroy withVars: {
+				} andCode: {
+					FT_Done_FreeType: library
+					self
+				}
+			} _init
+		}
+		
+		loadFlags <- { _loadFlags }
+	}
+}
\ No newline at end of file
diff -r 1debeb21dd47 -r 3edd0169311a samples/freetype.tp
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/samples/freetype.tp	Sun Mar 22 19:10:32 2015 -0700
@@ -0,0 +1,180 @@
+#{
+	import: [
+		video
+		timer
+	] from: (sdl subsystems)
+	
+	import: [
+		quit
+	] from: (sdl eventTypes)
+	
+	import: [
+		streaming
+	] from: (sdl textureAccess)
+	
+	import: [
+		bgra8888
+	] from: (sdl pixelFormats)
+	
+	hex2 <- :num {
+		val <- hex: num
+		if: (val length) < 2 {
+			val <- "0" . val
+		}
+		val
+	}
+	
+	main <- :args {
+		retcode <- 0
+		dpi <- 96
+		arg <- 1
+		expectVal <- false
+		optName <- ""
+		path <- ""
+		while: { arg < (args length) } do: {
+			curArg <- args get: arg
+			if: expectVal {
+				if: optName = "--dpi" || optName = "-d" {
+					dpi <- curArg int32
+				} else: {
+					print: "Unrecognized option: " . optName . "\n"
+				}
+				expectVal <- false
+			} else: {
+				if: (curArg startsWith?: "-") {
+					expectVal <- true
+					optName <- curArg
+				} else: {
+					path <- curArg
+				}
+			}
+			arg <- arg + 1
+		}
+		ft <- freetype init
+		maybeFace <- ft faceFromPath: path index: 0
+		charCodes <- #[]
+		maybeFace value: :face {
+			charMap <- face charmap
+			foreach: charMap :char glyph {
+				print: "Char: " . char . ", glyph index: " . glyph . "\n"
+				charCodes append: char
+			}
+			
+			if: (sdl init: (video or timer)) = 0 {
+				(sdl createWindow: "Freetype Test" pos: 0 0 size: 512 512 flags: 0u32) value: :window {
+					(window createRenderer: -1 flags: ((window renderOpts) accelerated)) value: :renderer {
+						renderer drawColor!: (sdl r: 255u8 g: 255u8 b: 255u8)
+						(renderer createTexture: bgra8888 access: streaming width: 512 height: 512) value: :drawTex {
+							drawTex blendMode!: ((sdl blendModes) blend)
+							drawTex lockRect: (sdl rect: 0 0 size: 512 512) with: :bytearr pitch {
+								i <- 0
+								n <- charCodes length
+								maxHeight <- 0
+								startY <- 0
+								startX <- 0
+								slot <- face glyphSlot
+								face setCharSize: 12.0 res: dpi
+								while: { i < n && startY < 512 } do: {
+									charCode <- charCodes get: i
+									glyphIndex <- charMap get: charCode else: { 0 }
+									rescode <- face loadGlyph: glyphIndex flags: ((freetype loadFlags) render)
+									if: rescode = 0 {
+										height <- slot bitmapRows
+										width <- slot bitmapWidth
+										if: startX + width > 512 {
+											startY <- startY + maxHeight
+											startX <- 0
+											maxHeight <- 0
+										}
+										
+										if: height > maxHeight {
+											maxHeight <- height
+										}
+										
+										if: height + startY > 512 {
+											startY <- 512
+										} else: {
+											print: "Rendering glyph " . glyphIndex . " to " . startX . ", " . startY . " (" . (startY * pitch  + 4 * startX) . ")\n"
+											print: "Width: " . width . ", Height: " . height . "\n"
+											destY <- startY
+											srcY <- 0
+											srcPitch <- slot bitmapPitch
+											srcBitmap <- slot bitmapData
+											while: { srcY < height } do: {
+												line <- ""
+												destIndex <- destY * pitch + startX * 4
+												srcIndex <- srcY * srcPitch
+												destX <- startX
+												srcX <- 0
+												while: { srcX < width } do: {
+													srcPixel <- srcBitmap get: srcIndex
+													bytearr set: destIndex srcPixel
+													destIndex <- destIndex + 1
+													bytearr set: destIndex 0u8
+													destIndex <- destIndex + 1
+													bytearr set: destIndex 0u8
+													destIndex <- destIndex + 1
+													bytearr set: destIndex 0u8
+													line <- line . " " . (hex2: srcPixel)
+												
+													destX <- destX + 1
+													srcX <- srcX + 1
+													destIndex <- destIndex + 1
+													srcIndex <- srcIndex + 1
+												}
+												print: line . "\n"
+												destY <- destY + 1
+												srcY <- srcY + 1
+											}
+										}
+										startX <- startX + width
+										
+										i <- i + 1
+									} else: {
+										print: "Got error " . rescode . " when loading glyph " . glyphIndex . "\n"
+									}
+								} 
+							}
+							continue? <- true
+							while: { continue? } do: {
+								renderer clear
+								drawTex copy
+								renderer present
+								event <- option none
+								while: {
+									event <- sdl pollEvent
+									event value?
+								} do: {
+									event value: :ev {
+										if: (ev type) = quit {
+											continue? <- false
+										}
+									} none: {}
+								}
+							}
+						} none: {
+							print: "Failed to create texture\n"
+							retcode <- 1
+						}
+					} none: {
+						print: "Failed to create renderer\n"
+						retcode <- 1
+					}
+					window destroy
+				} none: {
+					print: "Failed to create window\n"
+					retcode <- 1
+				}
+			} else: {
+				print: "Failed to initialize SDL\n"
+				retcode <- 1
+			}
+		} none: {
+			retcode <- 1
+			print: "Failed to load font face from " . path . "\n"
+		}
+		
+		ft destroy
+		retcode
+	}
+}
\ No newline at end of file