view modules/sdl.tp @ 283:0ec4f1b68a38

Add copyTo method to texture that allows copying to a rectangular region on the renderer rather than stretching to fit the entire renderer
author Michael Pavone <pavone@retrodev.com>
date Mon, 21 Jul 2014 20:27:38 -0700
parents eb83863fd33e
children 99c18127da04
line wrap: on
line source

{
	_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
		})
	}
	_subsystems <- #{
		_constant: timer SDL_INIT_TIMER
		_constant: audio SDL_INIT_AUDIO
		_constant: video SDL_INIT_VIDEO
		_constant: joystick SDL_INIT_JOYSTICK
		_constant: haptic SDL_INIT_HAPTIC
		_constant: gameController SDL_INIT_GAMECONTROLLER
		_constant: events SDL_INIT_EVENTS
		_constant: everything SDL_INIT_EVERYTHING
	}

	_windowOpts <- #{
		_constant: fullscreen SDL_WINDOW_FULLSCREEN
		_constant: fullscreenDesktop SDL_WINDOW_FULLSCREEN_DESKTOP
		_constant: opengl SDL_WINDOW_OPENGL
		_constant: hidden SDL_WINDOW_HIDDEN
		_constant: borderless SDL_WINDOW_BORDERLESS
		_constant: minimized SDL_WINDOW_MINIMIZED
		_constant: maximized SDL_WINDOW_MAXIMIZED
		_constant: inputGrabbed SDL_WINDOW_INPUT_GRABBED
		_constant: allowHighDPI SDL_WINDOW_ALLOW_HIGHDPI
	}

	_renderOpts <- #{
		_constant: software SDL_RENDERER_SOFTWARE
		_constant: accelerated SDL_RENDERER_ACCELERATED
		_constant: presentVSYNC SDL_RENDERER_PRESENTVSYNC
		_constant: targetTexture SDL_RENDERER_TARGETTEXTURE

	}

	_helper <- #{
		llMessage: createWindow withVars: {
			title <- string ptr
			x <- obj_int32 ptr
			y <- obj_int32 ptr
			w <- obj_int32 ptr
			h <- obj_int32 ptr
			flags <- obj_uint32 ptr
			makeWindow <- lambda ptr
			windowOpaque <- cpointer ptr
			win <- object ptr
		} andCode: :title x y w h flags makeWindow {
			windowOpaque <- make_object: (addr_of: cpointer_meta) NULL 0
			windowOpaque val!: (SDL_CreateWindow: (title data) (x num) (y num) (w num) (h num) (flags num))
			if: (windowOpaque val) {
				win <- ccall: makeWindow 1 (windowOpaque castTo: (object ptr))
				mcall: value 2 option win
			} else: {
				mcall: none 1 option
			}
		}

		llMessage: createRenderer withVars: {
			window <- cpointer ptr
			index <- obj_int32 ptr
			flags <- obj_uint32 ptr
			rendOpaque <- cpointer ptr
			rend <- object ptr
			makeRender <- lambda ptr
		} andCode: :window index flags makeRender {
			rendOpaque <- make_object: (addr_of: cpointer_meta) NULL 0
			rendOpaque val!: (SDL_CreateRenderer: (window val) (index num) (flags num))
			if: (rendOpaque val) {
				rend <- ccall: makeRender 1 (rendOpaque castTo: (object ptr))
				mcall: value 2 option rend
			} else: {
				mcall: none 1 option
			}
		}

		llMessage: loadBMP withVars: {
			filename <- string ptr
			makeSurface <- lambda ptr
			surfOpaque <- cpointer ptr
			surf <- object ptr
		} andCode: :filename makeSurface{
			surfOpaque <- make_object: (addr_of: cpointer_meta) NULL 0
			surfOpaque val!: (SDL_LoadBMP: (filename data))
			if: (surfOpaque val) {
				surf <- ccall: makeSurface 1 (surfOpaque castTo: (object ptr))
				mcall: value 2 option surf
			} else: {
				mcall: none 1 option
			}
		}

		llMessage: createTextureFromSurface withVars: {
			rendOpaque <- cpointer ptr
			surfOpaque <- cpointer ptr
			makeTexture <- lambda ptr
			texOpaque <- cpointer ptr
			tex <- object ptr
		} andCode: :rendOpaque surfOpaque makeTexture {
			texOpaque <- make_object: (addr_of: cpointer_meta) NULL 0
			texOpaque val!: (SDL_CreateTextureFromSurface: (rendOpaque val) (surfOpaque val))
			if: (texOpaque val) {
				tex <- ccall: makeTexture 1 (rendOpaque castTo: (object ptr)) (texOpaque castTo: (object ptr))
				mcall: value 2 option tex
			} else: {
				mcall: none 1 option
			}
		}
	}

	_makeTexture <- :rendptr texptr {
		#{
			includeSystemHeader: "SDL.h"
			llProperty: renderer withType: (SDL_Renderer ptr)
			llProperty: texture withType: (SDL_Texture ptr)
			llMessage: opaque withVars: {
				ptr <- cpointer ptr
			} andCode: {
				ptr <- make_object: (addr_of: cpointer_meta) NULL 0
				ptr val!: texture
				ptr
			}
			llMessage: _ptr_init withVars: {
				rendptr <- cpointer ptr
				texptr <- cpointer ptr
			} andCode: :rendptr texptr{
				renderer <- rendptr val
				texture <- texptr val
				self
			}

			llMessage: copy withVars: {
				intret <- obj_int32 ptr
			} andCode: {
				intret <- make_object: (addr_of: obj_int32_meta) NULL 0
				intret num!: (SDL_RenderCopy: renderer texture NULL NULL)
				intret
			}

			llMessage: copyTo withVars: {
				dst <- object ptr
				dstOpaque <- cpointer ptr
				intret <- obj_int32 ptr
			} andCode: :dst {
				dstOpaque <- (mcall: _rectPointer 1 dst) castTo: (cpointer ptr)
				intret <- make_object: (addr_of: obj_int32_meta) NULL 0
				intret num!: (SDL_RenderCopy: renderer texture NULL (dstOpaque val))
				intret
			}

			llMessage: destroy withVars: {} andCode: {
				SDL_DestroyTexture: texture
				true
			}
		} _ptr_init: rendptr texptr
	}

	_makeSurface <- :ptr {
		#{
			includeSystemHeader: "SDL.h"
			llProperty: surface withType: (SDL_Surface ptr)
			llMessage: opaque withVars: {
				ptr <- cpointer ptr
			} andCode: {
				ptr <- make_object: (addr_of: cpointer_meta) NULL 0
				ptr val!: surface
				ptr
			}
			llMessage: _ptr_init withVars: {
				ptr <- cpointer ptr
			} andCode: :ptr{
				surface <- ptr val
				self
			}

			asTexture <- :renderer {
				_helper createTextureFromSurface: (renderer opaque) opaque _makeTexture
			}

			llMessage: free withVars: {} andCode: {
				SDL_FreeSurface: surface
				true
			}
		} _ptr_init: ptr
	}

	#{
		includeSystemHeader: "SDL.h"
		includeSystemHeader: "stdlib.h"

		llMessage: init withVars: {
			flags <- obj_uint32 ptr
			intret <- obj_int32 ptr
		} andCode: :flags {
			intret <- make_object: (addr_of: obj_int32_meta) NULL 0
			intret num!: (SDL_Init: (flags num))
			if: (intret num) {
				atexit: SDL_Quit
			}
			intret
		}

		llMessage: initSubSystem withVars: {
			flags <- obj_uint32 ptr
			intret <- obj_int32 ptr
		} andCode: :flags {
			intret <- make_object: (addr_of: obj_int32_meta) NULL 0
			intret num!: (SDL_InitSubSystem: (flags num))
			intret
		}

		llMessage: quitSubSystem withVars: {
			flags <- obj_uint32 ptr
		} andCode: :flags {
			SDL_QuitSubSystem: (flags num)
			true
		}

		r:g:b:a <- :rc :gc :bc :ac {
			#{
				r <- rc
				g <- gc
				b <- bc
				a <- ac
			}
		}

		r:g:b <- :r :g :b {
			r: r g: g b: b a: 255u8
		}

		createWindow:pos:size:flags <- :title :x y :w h :flags{
			_helper createWindow: title x y w h flags :ptr {
				print: (string: ptr) . "\n"
				#{
					includeSystemHeader: "SDL.h"
					llProperty: window withType: (SDL_Window ptr)
					llMessage: opaque withVars: {
						op <- cpointer ptr
					} andCode: {
						op <- make_object: (addr_of: cpointer_meta) NULL 0
						op val!: window
						op
					}

					llMessage: _ptr_init withVars: {
						ptr <- cpointer ptr
					} andCode: :ptr {
						window <- ptr val
						self
					}

					renderOpts <- { _renderOpts }

					createRenderer:flags <- :index :flags {
						_helper createRenderer: (self opaque) index flags :ptr {
							#{
								includeSystemHeader: "SDL.h"
								llProperty: renderer withType: (SDL_Renderer ptr)
								llMessage: opaque withVars: {
									op <- cpointer ptr
								} andCode: {
									op <- make_object: (addr_of: cpointer_meta) NULL 0
									op val!: renderer
									op
								}
								llMessage: _ptr_init withVars: {
									ptr <- cpointer ptr
								} andCode: :ptr {
									renderer <- ptr val
									self
								}

								llMessage: drawColor! withVars: {
									color <- object ptr
									rc <- obj_uint8 ptr
									gc <- obj_uint8 ptr
									bc <- obj_uint8 ptr
									ac <- obj_uint8 ptr
									intret <- obj_int32 ptr
								} andCode: :color {
									intret <- make_object: (addr_of: obj_int32_meta) NULL 0
									rc <- (mcall: r 1 color) castTo: (obj_uint8 ptr)
									gc <- (mcall: g 1 color) castTo: (obj_uint8 ptr)
									bc <- (mcall: b 1 color) castTo: (obj_uint8 ptr)
									ac <- (mcall: a 1 color) castTo: (obj_uint8 ptr)
									intret num!: (SDL_SetRenderDrawColor: renderer (rc num) (gc num) (bc num) (ac num))
									intret
								}

								llMessage: clear withVars: {
									intret <- obj_int32 ptr
								} andCode: {
									intret <- make_object: (addr_of: obj_int32_meta) NULL 0
									intret num!: (SDL_RenderClear: renderer)
									intret
								}

								llMessage: present withVars: {} andCode: {
									SDL_RenderPresent: renderer
									true
								}

								llMessage: destroy withVars: {} andCode: {
									SDL_DestroyRenderer: renderer
									true
								}
							} _ptr_init: ptr
						}
					}

					llMessage: destroy withVars: {
					} andCode: {
						SDL_DestroyWindow: window
						true
					}
				} _ptr_init: ptr
			}
		}

		loadBMP <- :filename {
			_helper loadBMP: filename _makeSurface
		}

		llMessage: delay withVars: {
			ms <- obj_uint32 ptr
		} andCode: :ms {
			SDL_Delay: (ms num)
			true
		}

		llMessage: clearError withVars: {} andCode: {
			SDL_ClearError:
			true
		}

		rect:size <- :x y :w h {
			getter <- macro: :propName {
				quote: (llMessage: propName withVars: {
					intret <- obj_int32 ptr
				} andCode: {
					intret <- make_object: (addr_of: obj_int32_meta) NULL 0
					intret num!: ((addr_of: rect) propName)
					intret
				})
			}
			setter <- macro: :propName {
				quote: (llMessage: propName withVars: {
					v <- obj_int32 ptr
				} andCode: :v {
					(addr_of: rect) propName: (v num)
					self
				})
			}
			(((#{
				llProperty: rect withType: SDL_Rect
				getter: x
				setter: x!
				getter: y
				setter: y!
				getter: w
				setter: w!
				getter: h
				setter: h!
				llMessage: _rectPointer withVars: {
					retptr <- cpointer ptr
				} andCode: {
					retptr <- make_object: (addr_of: cpointer_meta) NULL 0
					retptr val!: (addr_of: (self rect))
					retptr
				}
			} x!: x) y!: y) w!: w) h!: h
		}

		llMessage: getError withVars: {
			str <- string ptr
			rawstr <- char ptr
		} andCode: {
			rawstr <- SDL_GetError:
			str <- make_object: (addr_of: string_meta) NULL 0
			str bytes!: (strlen: rawstr)
			str len!: (str bytes)
			str data!: (GC_MALLOC: (str bytes) + 1)
			memcpy: (str data) rawstr (str bytes) + 1
			str
		}

		subsystems <- { _subsystems }
		windowOpts <- { _windowOpts }
	}
}