view samples/freetype.tp @ 321:3edd0169311a

Add basic binding to Freetype2
author Michael Pavone <pavone@retrodev.com>
date Sun, 22 Mar 2015 19:10:32 -0700
parents
children 615f23450f8f
line wrap: on
line source

#{
	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
	}
}