diff --git a/libraries/libgambit/0001-Fix-incorrect-space-allocation-report-by-time-specia.patch b/libraries/libgambit/0001-Fix-incorrect-space-allocation-report-by-time-specia.patch new file mode 100644 index 00000000..60207b0c --- /dev/null +++ b/libraries/libgambit/0001-Fix-incorrect-space-allocation-report-by-time-specia.patch @@ -0,0 +1,50 @@ +From e529b1d6d5b7bae2fcc3e9cd8e7f3e11a1318193 Mon Sep 17 00:00:00 2001 +From: Marc Feeley +Date: Sun, 28 Mar 2021 19:29:54 -0400 +Subject: [PATCH] Fix incorrect space allocation report by time special form + +--- + lib/_kernel.scm | 6 ++++-- + lib/mem.c | 3 ++- + 2 files changed, 6 insertions(+), 3 deletions(-) + +diff --git a/lib/_kernel.scm b/lib/_kernel.scm +index 59b9e41..2d827dd 100644 +--- lib/_kernel.scm ++++ lib/_kernel.scm +@@ -4346,7 +4346,9 @@ end-of-code + + if (!___FIXNUMP(result)) + { +- n = ___bytes_allocated (___PSPNC) - n; ++ ___F64 ba = ___bytes_allocated (___PSPNC); ++ ++ n = ba - n; + + ___process_times (&user, &sys, &real); + ___vm_stats (&minflt, &majflt); +@@ -4358,7 +4360,7 @@ end-of-code + ___F64VECTORSET(result,___FIX(4),___vms->mem.gc_sys_time_) + ___F64VECTORSET(result,___FIX(5),___vms->mem.gc_real_time_) + ___F64VECTORSET(result,___FIX(6),___vms->mem.nb_gcs_) +- ___F64VECTORSET(result,___FIX(7),___bytes_allocated (___PSPNC)) ++ ___F64VECTORSET(result,___FIX(7),ba) + ___F64VECTORSET(result,___FIX(8),(2*(1+2)<<___LWS)) + ___F64VECTORSET(result,___FIX(9),n) + ___F64VECTORSET(result,___FIX(10),minflt) +diff --git a/lib/mem.c b/lib/mem.c +index 2c6cafd..9223da1 100755 +--- lib/mem.c ++++ lib/mem.c +@@ -7080,7 +7080,8 @@ ___PSDKR) + alloc_stack_ptr = ___ps->fp; + alloc_heap_ptr = ___ps->hp; + +- return bytes_allocated_minus_occupied + bytes_occupied(___ps); ++ return bytes_allocated_minus_occupied + bytes_occupied(___ps) + ++ ___CAST(___F64,occupied_words_still) * ___WS; + } + + +-- +2.20.1 diff --git a/loaders/win32/win32_microgl.c b/loaders/win32/win32_microgl.c index 6d40dbc0..dbad8230 100644 --- a/loaders/win32/win32_microgl.c +++ b/loaders/win32/win32_microgl.c @@ -95,6 +95,8 @@ static int _microgl_key(WPARAM wParam, LPARAM lParam, int modifier, int action) case VK_DOWN: return EVENT_KEYDOWN; case VK_HOME: return EVENT_KEYHOME; case VK_END: return EVENT_KEYEND; + case VK_PRIOR: return 0xff55; + case VK_NEXT: return 0xff56; default: // if CTRL is down, ToAscii puts ^A to ^Z (0x01 to 0x1a) in char_buf // if ALT is down, ToAscii puts a to z (lowercase) in char_buf diff --git a/loaders/x11/x11_microgl.c b/loaders/x11/x11_microgl.c index cd70d8b5..a87b2599 100644 --- a/loaders/x11/x11_microgl.c +++ b/loaders/x11/x11_microgl.c @@ -111,6 +111,7 @@ void microgl_refresh() event.type = Expose; event.xany.window = win.Win; XSendEvent(Dpy, win.Win, False, Expose, &event); + XSync(Dpy, 0); } // https://tronche.com/gui/x/xlib/events/keyboard-pointer/keyboard-pointer.html @@ -139,6 +140,9 @@ int _microgl_key( XKeyEvent *event ) case XK_Right: return EVENT_KEYRIGHT; case XK_Down: return EVENT_KEYDOWN; case XK_Up: return EVENT_KEYUP; + case XK_Page_Up: /* 0xff55 */ + case XK_Page_Down: /* 0xff56 */ + return keysym; } // Printable chars (Latin 1) if( (keysym >= 0x0020 && keysym <= 0x007e) || // Basic Latin 1 charset @@ -180,7 +184,7 @@ void _microgl_sendCopyStringEvent(XSelectionRequestEvent* selReqEv) { .time = CurrentTime }; if (copiedString && selReqEv->target == format && selReqEv->property != None) { - XChangeProperty(Dpy, selReqEv->requestor, selReqEv->property, format, 8, PropModeReplace, copiedString, copiedStringLen + 1); + XChangeProperty(Dpy, selReqEv->requestor, selReqEv->property, format, 8, PropModeReplace, copiedString, copiedStringLen); } else { selEv.property = None; } @@ -246,7 +250,7 @@ void microgl_pollevents(void) motion=1; break; case Expose: - expose=1; + expose = expose || (event.xexpose.width && event.xexpose.height) ? 1 : 0; break; case ClientMessage: if( (Atom) event.xclient.data.l[ 0 ] == win.WMDeleteWindow ) diff --git a/make.sh b/make.sh index 3b48f374..c61d0e66 100755 --- a/make.sh +++ b/make.sh @@ -378,6 +378,7 @@ compile_payload() hookhash=`stringhash "apps/$SYS_APPNAME/hook.c"` hctgt="$SYS_PREFIX/build/$hookhash.c" hotgt=`echo "$hctgt" | sed 's/c$/o/'` + rmifexists "$hotgt" cp loaders/hook/hook.c "$hctgt" veval "$SYS_ENV $SYS_CC $payload_cdefs $languages_def -c -o $hotgt $hctgt -I$SYS_PREFIX/include" assertfile $hotgt diff --git a/modules/clipboard/ANDROID_java_activityadditions b/modules/clipboard/ANDROID_java_activityadditions index c327aa5d..58fa870e 100644 --- a/modules/clipboard/ANDROID_java_activityadditions +++ b/modules/clipboard/ANDROID_java_activityadditions @@ -1,11 +1,10 @@ private String getClipboardContent(){ if (!(mClipboardManager.hasPrimaryClip())) { return ""; - } else if (mClipboardManager.getPrimaryClipDescription().hasMimeType(ClipDescription.MIMETYPE_TEXT_PLAIN)) { + } else /* if (mClipboardManager.getPrimaryClipDescription().hasMimeType(ClipDescription.MIMETYPE_TEXT_PLAIN)) */ { ClipData.Item item = mClipboardManager.getPrimaryClip().getItemAt(0); - return item.getText().toString(); + return item.coerceToText(this).toString(); } - return ""; } private int setClipboardContent(String str){ diff --git a/modules/clipboard/clipboard.scm b/modules/clipboard/clipboard.scm index 8d3ed529..c2a59bb3 100644 --- a/modules/clipboard/clipboard.scm +++ b/modules/clipboard/clipboard.scm @@ -36,6 +36,8 @@ OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. |# +(c-declare "#include ") ;; debug + (c-declare #<list obj)) obj))))) +(define (json-set-options! #!key (symbols #f) (tables #f) (keys #f)) + (set! use-symbols? symbols) + (set! use-tables? tables) + (set! use-symbols-for-keys? keys)) + +(define-macro (->string obj) + `(cond + ((symbol? ,obj) (symbol->string ,obj)) + (else ,obj))) + (define (json-decode str) (call-with-input-string str json-read)) @@ -175,7 +186,10 @@ SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (if (json-error? val) val (let ((new-rev-elements - (cons (cons str val) rev-elements))) + (cons (cons (if use-symbols-for-keys? + (string->symbol str) + str) val) + rev-elements))) (space) (let ((c (pk))) (cond ((eqv? c #\}) @@ -350,7 +364,7 @@ SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (display #\" port))))) (define (wr-prop prop) - (wr-string (car prop)) + (wr-string (->string (car prop))) (display ":" port) (wr (cdr prop))) diff --git a/modules/ln_core/time.scm b/modules/ln_core/time.scm index 12048920..19fecc01 100644 --- a/modules/ln_core/time.scm +++ b/modules/ln_core/time.scm @@ -258,9 +258,10 @@ end-of-c-declare ;; thanks, Martin Gasbichler ... (define (copy-time time) - (make-srfi19:time (srfi19:time-type time) - (srfi19:time-second time) - (srfi19:time-nanosecond time))) + (make-srfi19:time + (srfi19:time-type time) + (srfi19:time-nanosecond time) + (srfi19:time-second time))) ;;; current-time diff --git a/modules/ln_glcore/glcore-ffi.scm b/modules/ln_glcore/glcore-ffi.scm index e963d3c8..9fffa124 100644 --- a/modules/ln_glcore/glcore-ffi.scm +++ b/modules/ln_glcore/glcore-ffi.scm @@ -169,6 +169,16 @@ ___result = GL_CLAMP_TO_EDGE; ((c-lambda (float float float) void "glTranslatef") (flo a) (flo b) (flo c))) +(define glTranslatef//checks (c-lambda (float float float) void "glTranslatef")) + + +(define glTranslatef/f32vector//checks + ;; call site argument checks are supposed to ensure type and length + (c-lambda + (scheme-object) void " +___F32* args = ___CAST(___F32*, ___BODY_AS(___arg1, ___tSUBTYPED)); +glTranslatef(args[0], args[1], args[2]);")) + (define (glScalef a b c) ((c-lambda (float float float) void "glScalef") (flo a) (flo b) (flo c))) diff --git a/modules/ln_glcore/glcore.scm b/modules/ln_glcore/glcore.scm index 4b030d89..e9f15bcc 100644 --- a/modules/ln_glcore/glcore.scm +++ b/modules/ln_glcore/glcore.scm @@ -37,9 +37,26 @@ SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. |# ;; Absolutely minimal OpenGL (ES) interface -(define glcore:debuglevel 0) -(define (glcore:log level . x) - (if (>= glcore:debuglevel level) (apply log-system (append (list "glcore: " x))))) +;;* Compiletime + +#| ;; enable manually in source +(define-cond-expand-feature profile) +;;|# + +(cond-expand + (debug + (define glcore:debuglevel 0) + (define (glcore:log level . x) + (if (>= glcore:debuglevel level) (apply log-system (append (list "glcore: " x)))))) + (else)) + +(cond-expand + (profile ;; ignore even when otherwise in `debug` mode + (define-macro (glcore:log . ignored) #!void)) + (debug) ;; defined by previous `debug` expansion + (else (define-macro (glcore:log . ignored) #!void))) + +;;* Runtime ;; ---------------------------------- ;; Initialization @@ -47,17 +64,39 @@ SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (define glCore:customhook #f) (define (glCore-registerhook h) (set! glCore:customhook h)) +(cond-expand + (android + (c-declare + ;; calls GLState.fromNativeInitDraw() + "extern void microgl_draw_before();") + (define-macro (microgl-draw-before) + '((c-lambda () void "microgl_draw_before")))) + (else + (define-macro (microgl-draw-before) + #!void))) + (define glCore:needsinit #t) (define (glCoreInit) - (if (and glCore:customhook app:width app:height) (begin + (microgl-draw-before) + (begin + ;; This block faithful rebuilds the legacy sequence, which was + ;; done in main.c/microgl_hook before on any EVENT_REDRAW + (glClearColor 0. 0. 0. 0.) + (glMatrixMode GL_PROJECTION) + (glLoadIdentity) ;; ?? Isn't only the last of these actually effective? + (glOrtho 0. (exact->inexact app:width) 0. (exact->inexact app:height) -1. 1.) + (glMatrixMode GL_MODELVIEW) + (glLoadIdentity) + (glClear GL_COLOR_BUFFER_BIT)) + (if (and glCore:customhook app:width app:height) (begin (glDisable GL_BLEND) - (glCore:customhook) + (glCore:customhook) (glDisable GL_CULL_FACE) (glDisable GL_DEPTH_TEST) (set! glCore:needsinit #t))) (if glCore:needsinit (begin (if (and app:width app:height) (begin - (glcore:log 5 "glCoreInit") + (glcore:log 5 "glCoreInit") ;; suspend/resume might invalidate the textures (glCoreTextureReset) (glClearColor 0. 0. 0. 0.) @@ -107,9 +146,9 @@ SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (set! glCore:alpha (color-alpha c))) (define (glCoreBegin type) - (set! glCore:cindex 0) - (set! glCore:vindex 0) - (set! glCore:tindex 0) + (set! glCore:cindex 0) + (set! glCore:vindex 0) + (set! glCore:tindex 0) (set! glCore:type type) ) @@ -118,10 +157,10 @@ SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (glVertexPointer (if glCore:use3D 3 2) GL_FLOAT 0 (if glCore:use3D glCore:varray3D glCore:varray)) (glColorPointer 4 GL_UNSIGNED_BYTE 0 glCore:carray) (if (or (fx= glCore:type GL_LINES) (fx= glCore:type GL_LINE_LOOP) (fx= glCore:type GL_LINE_STRIP)) - (begin + (begin (glDisable GL_TEXTURE_2D) (glDisableClientState GL_TEXTURE_COORD_ARRAY) - ) + ) (begin (glEnable GL_TEXTURE_2D) (glEnableClientState GL_TEXTURE_COORD_ARRAY) @@ -136,7 +175,7 @@ SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (ty (cond ((not txx) 0.5) ((let ((r (cdr xtra))) - (and (pair? r) (car r)))) + (and (pair? r) (car r)))) (else 0.5)))) (let ((x (flo x0)) (y (flo y0))) (f32vector-set! glCore:varray (fx+ glCore:vindex 0) x) @@ -151,7 +190,7 @@ SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (u8vector-set! glCore:carray (fx+ glCore:cindex 3) glCore:alpha) (set! glCore:cindex (fx+ glCore:cindex 4)) (set! glCore:use3D #f) - ))) + ))) ;; ------------------------------------------ ;; 3D rendering @@ -181,50 +220,246 @@ SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ))) ;; ---------------------------------- -;; textures - -;; each entry is a vector of initflag,texure,w,h,u8data,pixeltype -(define glCore:textures (##still-copy (make-table))) -(define glCore:tidx 0) -(define glCore:curtexture -1) - -(define (glCoreTextureCreate w h data . aux) - (glcore:log 5 "glCoreTextureCreate") - (let* ((o1x (pair? aux)) - (o2 (and o1x (cdr aux)))) - (let ((idx glCore:tidx) - (pixeltype - (cond +;; textures + +(cond-expand ;; CONSTRUCTION-CASE + ((or gambit debug) ;; tentative changes + ;;; intentions: + ;;; 1. hide globals glCore:textures and glCore:tidx (at least) + ;;; 2. (short term) replace vector with distinct type + + ;; (: (%%glCore:textures-ref t d) <<== (table-ref [abstract:glCore:textures] t d)) + (define %%glCore:textures-ref) + ;; glCoreTextureCreate EXPORTED - ubiquitious + ;;; + ;;; (: (glCoreTextureCreate w h data #!optional (interpolation GL_LINEAR) (wrap GL_CLAMP)) + ;;; -> fixnum) + (define glCoreTextureCreate) + ;; glCoreTextureReset -- TBD: unknown usage status + ;;; + ;;; (: glCoreTextureReset -> undefined) + ;;; + ;;; purpose: clear resources + (define glCoreTextureReset) + + ;; Implementation (volatile) + + (define-type glCore:texture + macros: prefix: %MATURITY+3%texture%macro- + %%valid ;; FIXME: factor out from immutable components + glidx ;; index (for opengl and internal table) + %%-???-u32vector ;; what is this? mutable? + width + height + (%%-???-u8vector:data unprintable:) + pixeltype + interpolation + wrap + ) + + (define (glCore:texture? x) (%MATURITY+3%texture%macro-glCore:texture? x)) ;; avoid eventually! + + (define (glCore:texture-valid? texture) + (%MATURITY+3%texture%macro-glCore:texture-%%valid texture)) + + (define (glCore:texture-invalidate! texture) + (%MATURITY+3%texture%macro-glCore:texture-%%valid-set! texture #f)) + + (define (glCore:texture-valid! texture) + (%MATURITY+3%texture%macro-glCore:texture-%%valid-set! texture #t)) + + (define (glCore:texture-%%-???-u32vector texture) ;; was vector-ref t 1 + (%MATURITY+3%texture%macro-glCore:texture-%%-???-u32vector texture)) + + (define (glCore:texture-width texture) + (%MATURITY+3%texture%macro-glCore:texture-width texture)) + + (define (glCore:texture-height texture) + (%MATURITY+3%texture%macro-glCore:texture-height texture)) + + (define (glCore:texture-data texture) + (%MATURITY+3%texture%macro-glCore:texture-%%-???-u8vector:data texture)) + + (define (glCore:texture-pixeltype texture) + (%MATURITY+3%texture%macro-glCore:texture-pixeltype texture)) + + (define (glCore:texture-pixeltype-set! texture) + (%MATURITY+3%texture%macro-glCore:texture-pixeltype texture)) + + (define (glCore:texture-interpolation texture) + (%MATURITY+3%texture%macro-glCore:texture-interpolation texture)) + + (define (glCore:texture-interpolation-set! texture) + (%MATURITY+3%texture%macro-glCore:texture-interpolation texture)) + + (define (glCore:texture-wrap texture) + (%MATURITY+3%texture%macro-glCore:texture-wrap texture)) + + (define (glCore:texture-wrap-set! texture) + (%MATURITY+3%texture%macro-glCore:texture-wrap texture)) + + (let (;; TBD: not thread safe, assert exclusive access at least in debug + (glCore:textures (make-table)) + (glCore:tidx 0) + ;; TBD: now never using ##still-copy + (maturity:use-still-copy/-1 (if #f ##still-copy identity))) + + ;; ?? should we use `(##still-copy (make-table))` for glCore:textures? + (define (glCore:textures-ref texture default) + (if (%MATURITY+3%texture%macro-glCore:texture? texture) + texture + (table-ref glCore:textures texture default))) + + (define (%%glCoreTextureCreate w h data #!optional (interpolation GL_LINEAR) (wrap GL_CLAMP)) + ;; (glcore:log 5 "glCoreTextureCreate") + #;(MATURITY -1 "legacy; TBD: ensure resources are actually released" 'glCoreTextureCreate) + (let ((idx glCore:tidx) + (pixeltype + (cond + ((fx= (u8vector-length data) (* w h)) GL_ALPHA) + ((fx= (u8vector-length data) (* 3 w h)) GL_RGB) + ((fx= (u8vector-length data) (* 4 w h)) GL_RGBA) + (else (log-error "glCoreTextureCreate: Invalid data range") #f)))) + (table-set! + glCore:textures idx + (%MATURITY+3%texture%macro-make-glCore:texture + #f ;; volatile + idx + (u32vector 0) ;; unknown + w h ;; 2d interval + (maturity:use-still-copy/-1 data) + pixeltype interpolation wrap)) + (set! glCore:tidx (fx+ glCore:tidx 1)) + idx)) + + ;; clear all textures + (define (%%glCoreTextureReset!) + (table-for-each + (lambda (k entry) + (when (glCore:texture-valid? entry) + (glDeleteTextures 1 (%MATURITY+3%texture%macro-glCore:texture-%%-???-u32vector entry)) + (glCore:texture-invalidate! entry))) + glCore:textures) + (when #f ;; should we clean references too? + (set! glCore:textures (make-table)) + (set! glCore:tidx 0))) + + (unless glCore:textures (%%reset!)) + + (set! glCoreTextureReset %%glCoreTextureReset!) + (set! %%glCore:textures-ref glCore:textures-ref) + (set! glCoreTextureCreate %%glCoreTextureCreate)) + + (define glCore:curtexture -1) ;; deprecated but required + + ) ;; end of tentative changes + (else ;; old version + + ;; each entry is a vector of initflag,texure,w,h,u8data,pixeltype + (define glCore:textures (##still-copy (make-table))) + (define glCore:tidx 0) + (define glCore:curtexture -1) + ;; forward compatible replacements + (define (%%glCore:textures-ref texture default) + (table-ref glCore:textures texture default)) + + (define (glCore:texture-valid? texture) + (vector-ref texture 0)) + + (define (glCore:texture-invalidate! texture) + (vector-set! texture 0 #f)) + + (define (glCore:texture-valid! texture) + (vector-set! texture 0 #t)) + + (define (glCore:texture-%%-???-u32vector texture) ;; was vector-ref t 1 + (vector-ref texture 1)) + + (define (glCore:texture-width texture) + (vector-ref texture 2)) + + (define (glCore:texture-height texture) + (vector-ref texture 3)) + + (define (glCore:texture-data texture) + (vector-ref texture 4)) + + (define (glCore:texture-pixeltype texture) + (vector-ref texture 5)) + + (define (glCore:texture-interpolation texture) + (vector-ref texture 6)) + + (define (glCore:texture-wrap texture) + (vector-ref texture 7)) + + (define (glCoreTextureCreate w h data . aux) + (glcore:log 5 "glCoreTextureCreate") + (let* ((o1x (pair? aux)) + (o2 (and o1x (cdr aux)))) + (let ((idx glCore:tidx) + (pixeltype + (cond ((fx= (u8vector-length data) (* w h)) GL_ALPHA) ((fx= (u8vector-length data) (* 3 w h)) GL_RGB) ((fx= (u8vector-length data) (* 4 w h)) GL_RGBA) (else (log-error "glCoreTextureCreate: Invalid data range") #f))) - (interpolation (if o1x (car aux) GL_LINEAR)) - (wrap (if (pair? o2) (car o2) GL_CLAMP))) - (table-set! glCore:textures idx - (##still-copy (vector #f (u32vector 0) w h (##still-copy data) pixeltype interpolation wrap))) - (set! glCore:tidx (fx+ glCore:tidx 1)) - idx))) + (interpolation (if o1x (car aux) GL_LINEAR)) + (wrap (if (pair? o2) (car o2) GL_CLAMP))) + (table-set! + glCore:textures idx + (##still-copy + (vector #f (u32vector 0) w h (##still-copy data) pixeltype interpolation wrap))) + (set! glCore:tidx (fx+ glCore:tidx 1)) + idx))) + ;; reset a texture entry + (define (_glCoreTextureReset t) + (glcore:log 5 "_glCoreTextureReset") + (let ((entry (%%glCore:textures-ref t #f))) + (if (and entry (glCore:texture-valid? entry)) + (begin + (glDeleteTextures 1 (glCore:texture-%%-???-u32vector entry)) + (glCore:texture-invalidate! entry))))) + + ;; clear all textures + (define (glCoreTextureReset) + (glcore:log 5 "glCoreTextureReset") + (let ((tlist '())) ;; collect list of entries + ;;; + ;;; Jikes: by ... no way! + (table-for-each (lambda (k v) (set! tlist (append tlist (list k)))) glCore:textures) + (for-each (lambda (t) (_glCoreTextureReset t)) tlist))) + + ) ;; end of old version + ) ;; end of CONSTRUCTION-CASE + + +(define (glCore:textures-ref + num #!optional + (failure (lambda (num) (error "glCore:textures-ref: unbound index" num)))) + (cond + ((fixnum? num) (or (%%glCore:textures-ref num #f) (failure num))) + (else (error "not a fixnum" num glCore:textures-ref)))) ;; return texture width (define (glCoreTextureWidth t) (glcore:log 5 "glCoreTextureWidth") - (let ((entry (table-ref glCore:textures t #f))) - (if entry (vector-ref entry 2) (begin + (let ((entry (%%glCore:textures-ref t #f))) + (if entry (glCore:texture-width entry) (begin (log-error "glCoreTextureWidth: unbound index " t) #f)))) ;; return texture height (define (glCoreTextureHeight t) (glcore:log 5 "glCoreTextureWidth") - (let ((entry (table-ref glCore:textures t #f))) - (if entry (vector-ref entry 3) (begin + (let ((entry (%%glCore:textures-ref t #f))) + (if entry (glCore:texture-height entry) (begin (log-error "glCoreTextureHeight: unbound index " t) #f)))) ;; return texture data (define (glCoreTextureData t) (glcore:log 5 "glCoreTextureData") - (let ((entry (table-ref glCore:textures t #f))) - (if entry (vector-ref entry 4) (begin + (let ((entry (%%glCore:textures-ref t #f))) + (if entry (glCore:texture-data entry) (begin (log-error "glCoreTextureData: unbound index " t) #f)))) ;; %%%%%%%%%%%%%%%%%%%% @@ -240,22 +475,22 @@ SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (define (glCoreClipPush . coords) (let* ((oldlist glcore:cliplist) (newcoords - (if (fx= (length coords) 4) - (map flo - (list (min (car coords) (caddr coords)) - (min (cadr coords) (cadddr coords)) - (max (car coords) (caddr coords)) - (max (cadr coords) (cadddr coords)))) - #f)) + (if (fx= (length coords) 4) + (map lambdanative#flo + (list (min (car coords) (caddr coords)) + (min (cadr coords) (cadddr coords)) + (max (car coords) (caddr coords)) + (max (cadr coords) (cadddr coords)))) + #f)) (newlist (if newcoords - (append (list newcoords) oldlist) - (if (null? oldlist) oldlist (cdr oldlist))))) + (append (list newcoords) oldlist) + (if (null? oldlist) oldlist (cdr oldlist))))) (if (not (null? newlist)) - (begin - (set! glcore:clipx1 (car (car newlist))) - (set! glcore:clipy1 (cadr (car newlist))) - (set! glcore:clipx2 (caddr (car newlist))) - (set! glcore:clipy2 (cadddr (car newlist))))) + (begin + (set! glcore:clipx1 (car (car newlist))) + (set! glcore:clipy1 (cadr (car newlist))) + (set! glcore:clipx2 (caddr (car newlist))) + (set! glcore:clipy2 (cadddr (car newlist))))) (set! glcore:cliplist newlist))) (define glCoreClipPop glCoreClipPush) @@ -266,39 +501,41 @@ SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;; polygons are not clipped at all (define (glCoreTextureDraw x y w0 h0 t x1 y1 x2 y2 r . colors) - (let ((entry (table-ref glCore:textures t #f))) - (if entry - (let ((w (flo (if (fx= (fix w0) 0) (vector-ref entry 2) w0))) - (h (flo (if (fx= (fix h0) 0) (vector-ref entry 3) h0)))) - (if (null? glcore:cliplist) - (if (pair? colors) - (glCore:TextureDrawUnClipped - (flo x) (flo y) w h t (flo x1) (flo y1) (flo x2) (flo y2) (flo r) - (car colors)) - (glCore:TextureDrawUnClipped - (flo x) (flo y) w h t (flo x1) (flo y1) (flo x2) (flo y2) (flo r))) - (if (pair? colors) - (glCore:TextureDrawClipped - (flo x) (flo y) w h t (flo x1) (flo y1) (flo x2) (flo y2) (flo r) - (car colors)) - (glCore:TextureDrawClipped - (flo x) (flo y) w h t (flo x1) (flo y1) (flo x2) (flo y2) (flo r))))) - (log-error "glCoreTextureDraw: unbound index " t)))) + (let ((entry (%%glCore:textures-ref t #f))) + (if entry + (let ((w (flo (if (fx= (fix w0) 0) (glCore:texture-width entry) w0))) + (h (flo (if (fx= (fix h0) 0) (glCore:texture-height entry) h0)))) + (if (null? glcore:cliplist) + (if (pair? colors) + (glCore:TextureDrawUnClipped + (flo x) (flo y) w h t (flo x1) (flo y1) (flo x2) (flo y2) (flo r) + (car colors)) + (glCore:TextureDrawUnClipped + (flo x) (flo y) w h t (flo x1) (flo y1) (flo x2) (flo y2) (flo r))) + (if (pair? colors) + (glCore:TextureDrawClipped + (flo x) (flo y) w h t (flo x1) (flo y1) (flo x2) (flo y2) (flo r) + (car colors)) + (glCore:TextureDrawClipped + (flo x) (flo y) w h t (flo x1) (flo y1) (flo x2) (flo y2) (flo r))))) + (log-error "glCoreTextureDraw: unbound index " t)))) (define (glCore:TextureDrawUnClipped x y w h t @x1 @y1 @x2 @y2 r . colors) (glcore:log 5 "glCoreTextureDrawUnclipped enter") - (let ((w2 (fl/ w 2.)) (h2 (fl/ h 2.))) - (glPushMatrix) - (glTranslatef (fl+ x w2) (fl+ y h2) 0.) - (glRotatef r 0. 0. 1.) - (_glCoreTextureBind t) - (glCoreBegin GL_TRIANGLE_STRIP) - (if (null? colors) (begin - (glCoreVertex2f (fl- w2) h2 @x1 @y2) - (glCoreVertex2f w2 h2 @x2 @y2) - (glCoreVertex2f (fl- w2) (fl- h2) @x1 @y1) - (glCoreVertex2f w2 (fl- h2) @x2 @y1) - )(let ((colors (list->vector (car colors)))) + (let ((w2 (fl/ w 2.)) (h2 (fl/ h 2.))) + (glPushMatrix) + (glTranslatef (fl+ x w2) (fl+ y h2) 0.) + (glRotatef r 0. 0. 1.) + (_glCoreTextureBind t) + (glCoreBegin GL_TRIANGLE_STRIP) + (if (null? colors) + (begin + (glCoreVertex2f (fl- w2) h2 @x1 @y2) + (glCoreVertex2f w2 h2 @x2 @y2) + (glCoreVertex2f (fl- w2) (fl- h2) @x1 @y1) + (glCoreVertex2f w2 (fl- h2) @x2 @y1) + ) + (let ((colors (list->vector (car colors)))) (glCoreColor (vector-ref colors 0)) (glCoreVertex2f (fl- w2) h2 @x1 @y2) (glCoreColor (vector-ref colors 1)) @@ -307,54 +544,54 @@ SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (glCoreVertex2f (fl- w2) (fl- h2) @x1 @y1) (glCoreColor (vector-ref colors 3)) (glCoreVertex2f w2 (fl- h2) @x2 @y1) - )) - (glCoreEnd) - (glPopMatrix) - ) + )) + (glCoreEnd) + (glPopMatrix) + ) (glcore:log 5 "glCoreTextureDrawUnclipped leave") ) (define (glCore:TextureDrawClipped x y w h t @x1 @y1 @x2 @y2 r . colors) (if (and (fl< x glcore:clipx2) (fl> (fl+ x w) glcore:clipx1) (fl< y glcore:clipy2) (fl> (fl+ y h) glcore:clipy1)) - (let* ((cx1 (flmax x glcore:clipx1)) - (cx2 (flmin (fl+ x w) glcore:clipx2)) - (cy1 (flmax y glcore:clipy1)) - (cy2 (flmin (fl+ y h) glcore:clipy2)) - (cw (fl- cx2 cx1)) - (ch (fl- cy2 cy1)) - (cw2 (fl/ cw 2.)) - (ch2 (fl/ ch 2.)) - (c@x1 (fl+ (fl* (fl/ (fl- cx1 x) w) (fl- @x2 @x1)) @x1)) - (c@x2 (fl+ (fl* (fl/ (fl- cx2 x) w) (fl- @x2 @x1)) @x1)) - (c@y1 (fl+ (fl* (fl/ (fl- cy1 y) h) (fl- @y2 @y1)) @y1)) - (c@y2 (fl+ (fl* (fl/ (fl- cy2 y) h) (fl- @y2 @y1)) @y1))) + (let* ((cx1 (flmax x glcore:clipx1)) + (cx2 (flmin (fl+ x w) glcore:clipx2)) + (cy1 (flmax y glcore:clipy1)) + (cy2 (flmin (fl+ y h) glcore:clipy2)) + (cw (fl- cx2 cx1)) + (ch (fl- cy2 cy1)) + (cw2 (fl/ cw 2.)) + (ch2 (fl/ ch 2.)) + (c@x1 (fl+ (fl* (fl/ (fl- cx1 x) w) (fl- @x2 @x1)) @x1)) + (c@x2 (fl+ (fl* (fl/ (fl- cx2 x) w) (fl- @x2 @x1)) @x1)) + (c@y1 (fl+ (fl* (fl/ (fl- cy1 y) h) (fl- @y2 @y1)) @y1)) + (c@y2 (fl+ (fl* (fl/ (fl- cy2 y) h) (fl- @y2 @y1)) @y1))) (glPushMatrix) (glTranslatef (fl+ cx1 cw2) (fl+ cy1 ch2) 0.) (glRotatef r 0. 0. 1.) (_glCoreTextureBind t) (glCoreBegin GL_TRIANGLE_STRIP) (if (null? colors) - (begin - (glCoreVertex2f (fl- cw2) ch2 c@x1 c@y2) - (glCoreVertex2f cw2 ch2 c@x2 c@y2) - (glCoreVertex2f (fl- cw2) (fl- ch2) c@x1 c@y1) - (glCoreVertex2f cw2 (fl- ch2) c@x2 c@y1) - ) - (let ((colors (list->vector (car colors)))) - ;; TODO: color interpolation here! - (glCoreColor (vector-ref colors 0)) - (glCoreVertex2f (fl- cw2) ch2 c@x1 c@y2) - (glCoreColor (vector-ref colors 1)) - (glCoreVertex2f cw2 ch2 c@x2 c@y2) - (glCoreColor (vector-ref colors 2)) - (glCoreVertex2f (fl- cw2) (fl- ch2) c@x1 c@y1) - (glCoreColor (vector-ref colors 3)) - (glCoreVertex2f cw2 (fl- ch2) c@x2 c@y1) - )) + (begin + (glCoreVertex2f (fl- cw2) ch2 c@x1 c@y2) + (glCoreVertex2f cw2 ch2 c@x2 c@y2) + (glCoreVertex2f (fl- cw2) (fl- ch2) c@x1 c@y1) + (glCoreVertex2f cw2 (fl- ch2) c@x2 c@y1) + ) + (let ((colors (list->vector (car colors)))) + ;; TODO: color interpolation here! + (glCoreColor (vector-ref colors 0)) + (glCoreVertex2f (fl- cw2) ch2 c@x1 c@y2) + (glCoreColor (vector-ref colors 1)) + (glCoreVertex2f cw2 ch2 c@x2 c@y2) + (glCoreColor (vector-ref colors 2)) + (glCoreVertex2f (fl- cw2) (fl- ch2) c@x1 c@y1) + (glCoreColor (vector-ref colors 3)) + (glCoreVertex2f cw2 (fl- ch2) c@x2 c@y1) + )) (glCoreEnd) (glPopMatrix) - ))) + ))) (define glCoreTextureGradientDraw glCoreTextureDraw) @@ -363,97 +600,84 @@ SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;; draw a texture (define (glCoreTexturePolygonDraw _cx _cy points t _r) (glcore:log 5 "glCoreTexturePolygonDraw") - (let ((entry (table-ref glCore:textures t #f))) + (let ((entry (%%glCore:textures-ref t #f))) (if entry - (let* ((cx (flo _cx)) (cy (flo _cy)) (r (flo _r))) - (glPushMatrix) - (glTranslatef cx cy 0.) - (glRotatef r 0. 0. 1.) - (_glCoreTextureBind t) - (glCoreBegin GL_TRIANGLE_STRIP) - (for-each - (lambda (p) - ;; TBD: should accept vectoralikes as point - (let* ((p (list->vector p)) - (x (fl- (vector-ref p 0) cx)) - (y (fl- (vector-ref p 1) cy)) - (tx (vector-ref p 2)) - (ty (vector-ref p 3))) - (glCoreVertex2f x y tx ty))) - points) - (glCoreEnd) - (glPopMatrix)) - (log-error "glCoreTexturePolygonDraw: unbound index " t)))) + (let* ((cx (flo _cx)) (cy (flo _cy)) (r (flo _r))) + (glPushMatrix) + (glTranslatef cx cy 0.) + (glRotatef r 0. 0. 1.) + (_glCoreTextureBind t) + (glCoreBegin GL_TRIANGLE_STRIP) + (for-each + (lambda (p) + ;; TBD: should accept vectoralikes as point + (let* ((p (list->vector p)) + (x (fl- (vector-ref p 0) cx)) + (y (fl- (vector-ref p 1) cy)) + (tx (vector-ref p 2)) + (ty (vector-ref p 3))) + (glCoreVertex2f x y tx ty))) + points) + (glCoreEnd) + (glPopMatrix)) + (log-error "glCoreTexturePolygonDraw: unbound index " t)))) ;; update texture data (for dynamic textures) ;; to use this, first modify data returned with glCoreTextureData.. (define (glCoreTextureUpdate t) (glcore:log 5 "glCoreTextureUpdate") + (if (fixnum? t) (set! t (%%glCore:textures-ref t #f))) (_glCoreTextureBind t) ;; select the texture as current - (let* ((entry (table-ref glCore:textures t #f)) - (w (vector-ref entry 2)) - (h (vector-ref entry 3)) - (data (vector-ref entry 4)) - (pixeltype (vector-ref entry 5))) - (glTexSubImage2D GL_TEXTURE_2D 0 0 0 w h pixeltype GL_UNSIGNED_BYTE data) - )) + (let ((entry t)) + (let ((w (glCore:texture-width entry)) + (h (glCore:texture-height entry)) + (data (glCore:texture-data entry)) + (pixeltype (glCore:texture-pixeltype entry))) + (glTexSubImage2D GL_TEXTURE_2D 0 0 0 w h pixeltype GL_UNSIGNED_BYTE data)))) + +(define (%%glCoreTextureInit! texture) ;; texture structure + (let ((u32t (glCore:texture-%%-???-u32vector texture)) + (w (glCore:texture-width texture)) + (h (glCore:texture-height texture)) + (data (glCore:texture-data texture)) + (pixeltype (glCore:texture-pixeltype texture)) + (interp (glCore:texture-interpolation texture)) + (wrap (glCore:texture-wrap texture))) + (glGenTextures 1 u32t) + (if (or (= (u32vector-ref u32t 0) GL_INVALID_VALUE) + ;; this is a general check that gl is working in this thread + (= (glIsEnabled GL_TEXTURE_2D) 0)) + (glcore:log 5 "_glCoreTextureInit: failed to generate texture") + (begin + (glCore:texture-valid! texture) ;; mark as initialized + (glBindTexture GL_TEXTURE_2D (u32vector-ref u32t 0)) + (glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER interp) + (glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER interp) + (glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_S wrap) + (glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_T wrap) + (glTexImage2D GL_TEXTURE_2D 0 pixeltype w h 0 pixeltype GL_UNSIGNED_BYTE data))))) (define (_glCoreTextureBind t) (glcore:log 5 "_glCoreTextureBind") - (let ((entry (table-ref glCore:textures t #f))) - (if entry (begin - (if (not (vector-ref entry 0)) (_glCoreTextureInit t)) - (let ((tx (u32vector-ref (vector-ref entry 1) 0))) - (if (not (= glCore:curtexture tx)) (begin - (glBindTexture GL_TEXTURE_2D tx) - (set! glCore:curtexture tx)))) - ) (log-error "glCoreTextureBind: unbound index " t) - ))) + (let ((entry (if (fixnum? t) (%%glCore:textures-ref t #f) t))) + (if entry + (begin + (unless (glCore:texture-valid? entry) + ;; TBD: maybe move into the reference operation? + (%%glCoreTextureInit! entry)) + (let ((tx (u32vector-ref (glCore:texture-%%-???-u32vector entry) 0))) + (if (not (= glCore:curtexture tx)) + (begin + (glBindTexture GL_TEXTURE_2D tx) + (set! glCore:curtexture tx))))) + (log-error "glCoreTextureBind: unbound index " t)))) (define (_glCoreTextureInit t) (glcore:log 5 "_glCoreTextureInit") - (let* ((entry (table-ref glCore:textures t #f)) - (u32t (vector-ref entry 1)) - (w (vector-ref entry 2)) - (h (vector-ref entry 3)) - (data (vector-ref entry 4)) - (pixeltype (vector-ref entry 5)) - (interp (vector-ref entry 6)) - (wrap (vector-ref entry 7))) - (glGenTextures 1 u32t) - (if (or (= (u32vector-ref u32t 0) GL_INVALID_VALUE) - ;this is a general check that gl is working in this thread - (= (glIsEnabled GL_TEXTURE_2D) 0)) - (glcore:log 5 "_glCoreTextureInit: failed to generate texture") - (begin - (vector-set! entry 0 #t) ;; mark as initialized - (glBindTexture GL_TEXTURE_2D (u32vector-ref u32t 0)) - (glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER interp) - (glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER interp) - (glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_S wrap) - (glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_T wrap) - (glTexImage2D GL_TEXTURE_2D 0 pixeltype w h 0 pixeltype GL_UNSIGNED_BYTE data) - )) - )) - -;; reset a texture entry -(define (_glCoreTextureReset t) - (glcore:log 5 "_glCoreTextureReset") - (let* ((entry (table-ref glCore:textures t #f)) - (u32t (vector-ref entry 1))) - (if (vector-ref entry 0) (begin - (glDeleteTextures 1 u32t) - (vector-set! entry 0 #f) ;; mark as uninitialized - )) - )) - -;; clear all textures -(define (glCoreTextureReset) - (glcore:log 5 "glCoreTextureReset") - (let ((tlist '())) - (table-for-each (lambda (k v) (set! tlist (append tlist (list k)))) glCore:textures) - (for-each (lambda (t) (_glCoreTextureReset t)) tlist) - )) + (unless (fixnum? t) (error "_glCoreTextureInit: wrong argument type")) + (let ((entry (%%glCore:textures-ref t #f))) + (if entry (%%glCoreTextureInit! entry) + (log-error "_glCoreTextureInit: unknown index " t)))) ;; take screen shot (define (glCoreReadPixels x y w h) diff --git a/modules/ln_glgui/primitives.scm b/modules/ln_glgui/primitives.scm index db5e743c..89d15fe4 100644 --- a/modules/ln_glgui/primitives.scm +++ b/modules/ln_glgui/primitives.scm @@ -216,6 +216,31 @@ SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;; Reducing the computational complexity of font operations improves ;;; rendering time. +(define-type ln-ttf:glyph + macros: prefix: macro- + desc ;; for now legacy: (key (texcoord1..4) X Y Z) + width + height + texture + texcoords ;; generic 4 element vector of flownums + rect-texcoords ;; 4x2 element f32vector + ;; order is sorta important here + offsetx + advancex + offsety + ) + +(define (ttf:glyph? obj) (macro-ln-ttf:glyph? obj)) +(define (ttf:glyph-desc obj) (macro-ln-ttf:glyph-desc obj)) +(define (ttf:glyph-width obj) (macro-ln-ttf:glyph-width obj)) +(define (ttf:glyph-height obj) (macro-ln-ttf:glyph-height obj)) +(define (ttf:glyph-image obj) (macro-ln-ttf:glyph-texture obj)) +(define (ttf:glyph-texcoords obj) (macro-ln-ttf:glyph-texcoords obj)) +(define (ttf:glyph-rect-texcoords obj) (macro-ln-ttf:glyph-rect-texcoords obj)) +(define (ttf:glyph-offsetx obj) (macro-ln-ttf:glyph-offsetx obj)) +(define (ttf:glyph-advancex obj) (macro-ln-ttf:glyph-advancex obj)) +(define (ttf:glyph-offsety obj) (macro-ln-ttf:glyph-offsety obj)) + (define-type ln-ttf:font macros: prefix: macro- desc ;; for now the legacy description of a font as a assoc-list @@ -298,10 +323,14 @@ SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (loop (fl+ x0 gax) (cdr cs)))))) (define (glgui:fontheight fnt) - (let* ((g (assoc 0 fnt)) - (i (if g (glgui:glyph-image g) #f)) - (h (if i (glgui:image-h i) - (cadr (cadr (car fnt)))))) h)) + (cond + ((macro-ln-ttf:font? fnt) (ttf:glyph-height (MATURITY+1:ln-ttf:font-ref fnt 0))) + ((find-font fnt) => glgui:fontheight) + (else ;; MATURITY -1 backward compatible, the old code + (let* ((g (assoc 0 fnt)) + (i (if g (glgui:glyph-image g) #f)) + (h (if i (glgui:image-h i) + (cadr (cadr (car fnt)))))) h)))) (define (glgui:stringheight txt fnt) (define font (find-font fnt))