Mercurial > repos > tabletprog
view samples/freetype.tp @ 323:eb5f1fca9b78
Fix infinite loop in foldr:with
author | Michael Pavone <pavone@retrodev.com> |
---|---|
date | Mon, 23 Mar 2015 21:18:26 -0700 |
parents | 3edd0169311a |
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 } }