;;
     *)
	LIBGL=GL
	;;
esac
AC_SUBST(LIBADD)
AC_SUBST(LIBGL)



AC_CONFIG_FILES([Makefile])
AC_OUTPUT

	;;
     *)
	LIBGL=GL
	;;
esac
AC_SUBST(LIBADD)
AC_SUBST(LIBGL)
LIBTOOL=${CC%gcc}libtool
AC_SUBST(LIBTOOL)

AC_CONFIG_FILES([Makefile])
AC_OUTPUT

\ freetype GL example

\ needs wide char arguments

Variable wide$
Variable widec


: >wide$ ( addr u -- addr' u' )  s" " wide$ $!
    over + swap ?DO
        I xc@+ widec l! widec 4 wide$ $+!
    I - +LOOP  wide$ $@ ;

\ freetype stuff

require freetype-gl.fs

also freetype-gl
also opengl
................................................................................
    fover f- fnegate fd fmin fswap fh fmax ;

: layout-string ( addr u -- fw fh fd ) \ depth is ow far it goes down
    0 -rot  0e 0e 0e  bounds ?DO
	I xc@+ swap >r xchar@xy r>
    I - +LOOP  drop ;

: load-glyphs ( -- )
    font


    "#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_`abcdefghijklmnopqrstuvwxyz{|}~\0" >wide$ drop texture_font_load_glyphs drop ;

program init

: <render ( -- )
    program glUseProgram
    1-bias set-color+
    .01e 100e 100e >ap
    atlas-tex v0 i0 ;

: render> ( -- )  GL_TRIANGLES draw-elements
    ( Coloradd 0e fdup fdup fdup glUniform4f ) ;

previous previous

\ freetype GL example

\ needs wide char arguments

Variable wide$
Variable widec

: >widec ( char -- ) widec l! widec 4 wide$ $+! ;
: >wide$ ( addr u -- addr' )  s" " wide$ $!

    bounds ?DO  I xc@+ >widec  I - +LOOP  0 >widec  wide$ $@ drop ;


\ freetype stuff

require freetype-gl.fs

also freetype-gl
also opengl
................................................................................
    fover f- fnegate fd fmin fswap fh fmax ;

: layout-string ( addr u -- fw fh fd ) \ depth is ow far it goes down
    0 -rot  0e 0e 0e  bounds ?DO
	I xc@+ swap >r xchar@xy r>
    I - +LOOP  drop ;

: load-glyph$ ( addr u -- ) >wide$
    font swap texture_font_load_glyphs drop ;

: load-ascii ( -- )
    "#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_`abcdefghijklmnopqrstuvwxyz{|}~" load-glyph$ ;

program init

: <render ( -- )
    program glUseProgram
    1-bias set-color+
    .01e 100e 100e >ap
    atlas-tex v0 i0 ;

: render> ( -- )  GL_TRIANGLES draw-elements
    ( Coloradd 0e fdup fdup fdup glUniform4f ) ;

previous previous

\ opengl common stuff

require unix/mmap.fs
require mini-oof2.fs

: w, ( n -- )  here 2 allot w! ;
: l, ( n -- )  here 4 allot l! ;





s" os-type" environment? [IF]
    2dup s" linux-android" str= [IF] 2drop
	require opengl.fs
	
	also opengl
	
................................................................................
	    s" precision mediump float;        // required for GLES 2.0" ;
    [ELSE]
	s" linux-gnu" str= [IF]
	    require opengl/opengl.fs
	    
	    also opengl
	
	    require opengl/linux.fs
	    also \ same voc stack effect as on android

	    align here
	    GLX_SAMPLE_BUFFERS  l, 1 l,
	    GLX_SAMPLES         l, 4 l,
	    here
	    GLX_RED_SIZE        l, 8 l,
	    GLX_GREEN_SIZE      l, 8 l,
................................................................................
	: add-precision s" " ;
    [THEN]
[THEN]

Variable configs
Variable numconfigs
Variable eglformat
Variable dpy-w
Variable dpy-h

: ??gl .s ." gl: " glGetError . ; ' ??gl is printdebugdata

[IFDEF] android
    : win app window @ ;
    
    0 Value egldpy
    0 Value surface
    0 Value eglcontext
    
    : getwh ( -- )
	egldpy surface EGL_WIDTH dpy-w eglQuerySurface drop
	egldpy surface EGL_HEIGHT dpy-h eglQuerySurface drop
	0 0 dpy-w @ dpy-h @ glViewport ;

    : >screen-orientation ( -- )
................................................................................
		." default config only" EXIT
	    THEN
	THEN ;
    
    : create-context ( -- )
	win 0 0 eglformat ANativeWindow_setBuffersGeometry drop
	egldpy configs @ win 0 eglCreateWindowSurface to surface
	egldpy configs @ 0 eglattribs eglCreateContext to eglcontext
	egldpy surface dup eglcontext eglMakeCurrent drop ;

    : sync ( -- )
	egldpy surface eglSwapBuffers drop ;
[THEN]

[IFDEF] linux
    fpath+ gles2
    0 Value visual
    0 Value ctx

    \ I have no luck with glXChooseVisual - this is a replacement:
    Variable nitems
    Variable val
    : glXVisual? ( visinfo attrib -- flag ) true { flag }
	BEGIN  dup l@  WHILE
		2dup dpy -rot l@ val glXGetConfig drop
................................................................................
	REPEAT  2drop flag ;
    
    : glXChooseVisual' ( dpy screen attrib -- ) { attrib }
	pad nitems XGetVisualInfo nitems @ XVisualInfo * bounds ?DO
	    I attrib glXVisual?  IF  I unloop  EXIT  THEN
	XVisualInfo +LOOP 0 ;
    
    : choose-config ( -- )
	get-display dpy-h ! dpy-w !
	dpy screen attrib3 glXChooseVisual' dup 0= IF  drop
	    dpy screen attrib2 glXChooseVisual' dup 0= IF  drop
		dpy screen attrib glXChooseVisual' dup
		0= abort" Unable to choose Visual"
	    THEN
	THEN  to visual ;

    : create-context ( -- )
	default-events "GL-Window\0" drop dpy-w @ dpy-h @ simple-win
	dpy visual 0 1 glXCreateContext to ctx
	dpy win ctx glXMakeCurrent drop ;

    : getwh ( -- )
	0 0 dpy-w @ dpy-h @ glViewport ;

    : >screen-orientation ;

    : sync ( -- )
	dpy win glXSwapBuffers ;
[THEN]

: init-opengl ( -- )
................................................................................
0 Value LightPos
0 Value Texture
0 Value ambient
0 Value Coloradd
0 Value program

: create-program { vs-xt fs-xt -- program }


    glCreateProgram dup >r IF
	r@ vs-xt execute glAttachShader
	r@ fs-xt execute glAttachShader
	vs-xt r@ >bindattrib
	r@ glLinkProgram THEN
    r> ;

................................................................................
	I 4 sfloats bounds DO
	    I sf@ f.
	1 sfloats +LOOP cr
    4 sfloats +LOOP ;

: set-matrix ( addr handle -- ) swap >r
    1 false r> glUniformMatrix4fv ;




: set-color+ ( addr -- )  Coloradd 1 rot glUniform4fv ;

: >ortho { f: near f: far f: left f: right f: top f: bottom -- }
    ap-matrix
    near f2* right left f- f/ sf!+ 0e sf!+ 0e sf!+ 0e sf!+
    0e sf!+ near f2* top bottom f- f/ sf!+ 0e sf!+ 0e sf!+
................................................................................
: f>c ( r g b a -- )  c.a sf! c.b sf! c.g sf! c.r sf! ;
: n>xyz ( x y z -- ) n.z sf! n.y sf! n.x sf! 1e n.t sf! ;
: n> ( -- ) -1e n.z sf! 0e n.y sf! 0e n.x sf! 1e n.t sf! ;
: >st ( s t -- ) t.t sf! t.s sf! ;

\ window closed/reopened

: recompile-shaders ( -- )
    ['] VertexShader recompile-shader
    ['] FragmentShader recompile-shader ;

: helper-init  init-opengl texture-init recompile-shaders
    ['] VertexShader ['] FragmentShader create-program to program
    program init  buffer-init ;

:noname  defers window-init helper-init ; IS window-init

\ click region stuff

: click-regions ( w h -- x' y' )  >r >r
    *input x0 @ r> dpy-w @ */
    *input y0 @ r> dpy-h @ */ ;












































previous

\ opengl common stuff

require unix/mmap.fs
require mini-oof2.fs

: w, ( n -- )  here 2 allot w! ;
: l, ( n -- )  here 4 allot l! ;

Variable dpy-w
Variable dpy-h
0 Value ctx

s" os-type" environment? [IF]
    2dup s" linux-android" str= [IF] 2drop
	require opengl.fs
	
	also opengl
	
................................................................................
	    s" precision mediump float;        // required for GLES 2.0" ;
    [ELSE]
	s" linux-gnu" str= [IF]
	    require opengl/opengl.fs
	    
	    also opengl
	

	    require opengl/linux.fs \ same voc stack effect as on android

	    align here
	    GLX_SAMPLE_BUFFERS  l, 1 l,
	    GLX_SAMPLES         l, 4 l,
	    here
	    GLX_RED_SIZE        l, 8 l,
	    GLX_GREEN_SIZE      l, 8 l,
................................................................................
	: add-precision s" " ;
    [THEN]
[THEN]

Variable configs
Variable numconfigs
Variable eglformat



: ??gl .s ." gl: " glGetError . ; ' ??gl is printdebugdata

[IFDEF] android
    : win app window @ ;
    
    0 Value egldpy
    0 Value surface

    
    : getwh ( -- )
	egldpy surface EGL_WIDTH dpy-w eglQuerySurface drop
	egldpy surface EGL_HEIGHT dpy-h eglQuerySurface drop
	0 0 dpy-w @ dpy-h @ glViewport ;

    : >screen-orientation ( -- )
................................................................................
		." default config only" EXIT
	    THEN
	THEN ;
    
    : create-context ( -- )
	win 0 0 eglformat ANativeWindow_setBuffersGeometry drop
	egldpy configs @ win 0 eglCreateWindowSurface to surface
	egldpy configs @ 0 eglattribs eglCreateContext to ctx
	egldpy surface dup ctx eglMakeCurrent drop ;

    : sync ( -- )
	egldpy surface eglSwapBuffers drop ;
[THEN]

[IFDEF] linux
    fpath+ gles2
    0 Value visual


    \ I have no luck with glXChooseVisual - this is a replacement:
    Variable nitems
    Variable val
    : glXVisual? ( visinfo attrib -- flag ) true { flag }
	BEGIN  dup l@  WHILE
		2dup dpy -rot l@ val glXGetConfig drop
................................................................................
	REPEAT  2drop flag ;
    
    : glXChooseVisual' ( dpy screen attrib -- ) { attrib }
	pad nitems XGetVisualInfo nitems @ XVisualInfo * bounds ?DO
	    I attrib glXVisual?  IF  I unloop  EXIT  THEN
	XVisualInfo +LOOP 0 ;
    
    : choose-config ( -- ) \ visual ?EXIT
	get-display dpy-h ! dpy-w !
	dpy screen attrib3 glXChooseVisual' dup 0= IF  drop
	    dpy screen attrib2 glXChooseVisual' dup 0= IF  drop
		dpy screen attrib glXChooseVisual' dup
		0= abort" Unable to choose Visual"
	    THEN
	THEN  to visual ;

    : create-context ( -- ) \ win ?EXIT
	default-events "GL-Window\0" drop dpy-w @ dpy-h @ simple-win
	dpy visual 0 1 glXCreateContext to ctx
	dpy win ctx glXMakeCurrent drop ;




    : >screen-orientation ;

    : sync ( -- )
	dpy win glXSwapBuffers ;
[THEN]

: init-opengl ( -- )
................................................................................
0 Value LightPos
0 Value Texture
0 Value ambient
0 Value Coloradd
0 Value program

: create-program { vs-xt fs-xt -- program }
    vs-xt recompile-shader
    fs-xt recompile-shader
    glCreateProgram dup >r IF
	r@ vs-xt execute glAttachShader
	r@ fs-xt execute glAttachShader
	vs-xt r@ >bindattrib
	r@ glLinkProgram THEN
    r> ;

................................................................................
	I 4 sfloats bounds DO
	    I sf@ f.
	1 sfloats +LOOP cr
    4 sfloats +LOOP ;

: set-matrix ( addr handle -- ) swap >r
    1 false r> glUniformMatrix4fv ;

: >x-pos ( r -- ) x-pos sf!  unit-matrix MVPMatrix set-matrix ;
: >y-pos ( r -- ) y-pos sf!  unit-matrix MVPMatrix set-matrix ;

: set-color+ ( addr -- )  Coloradd 1 rot glUniform4fv ;

: >ortho { f: near f: far f: left f: right f: top f: bottom -- }
    ap-matrix
    near f2* right left f- f/ sf!+ 0e sf!+ 0e sf!+ 0e sf!+
    0e sf!+ near f2* top bottom f- f/ sf!+ 0e sf!+ 0e sf!+
................................................................................
: f>c ( r g b a -- )  c.a sf! c.b sf! c.g sf! c.r sf! ;
: n>xyz ( x y z -- ) n.z sf! n.y sf! n.x sf! 1e n.t sf! ;
: n> ( -- ) -1e n.z sf! 0e n.y sf! 0e n.x sf! 1e n.t sf! ;
: >st ( s t -- ) t.t sf! t.s sf! ;

\ window closed/reopened





: helper-init  init-opengl texture-init
    ['] VertexShader ['] FragmentShader create-program to program
    program init  buffer-init ;

:noname  defers window-init helper-init ; IS window-init

\ click region stuff

: click-regions ( w h -- x' y' )  >r >r
    *input x0 @ r> dpy-w @ */
    *input y0 @ r> dpy-h @ */ ;

\ toggle and drag time stuff

: ftime ( -- r ) ntime d>f 1e-9 f* ;

0.5e FConstant rel-drag
0.3e FConstant abs-drag
FVariable drag-time
: f!@ ( r1 addr -- r2 ) dup f@ fswap f! ;
: delta-t ( -- r )
    ftime fdup drag-time f!@ f- fdup 1e f> IF  fdrop 0e  THEN ;

Fvariable click-time
FVariable motion-x0
FVariable motion-y0
Variable last-x0  -100 last-x0 !
Variable last-y0  -100 last-y0 !
0.15e FConstant short-click#
0.5e  FConstant long-click#

: delta-tc  ftime click-time f@ f- ;
: short? ( -- flag )
    delta-tc short-click# f< ;
: long? ( -- flag )
    delta-tc long-click# f> ;
: !click ( -- ) ftime click-time f! ;
[IFUNDEF] togglekb : togglekb ; [THEN]
: ?toggle ( -- )
    short? motion-y0 f@ f0= and IF  togglekb need-show off  THEN ;

: do-motion { rows cur old motion xt -- }
    old @ -100 = IF
	cur old !
    ELSE
	cur old @ over old ! swap -
	s>f dpy-h @ s>f rows fm/ f/ fdup motion f! xt execute
    THEN ;

: drag-motion { old motion xt -- } delta-t { f: dt }
    motion f@ rel-drag dt f** f*
    fdup f0< fabs abs-drag dt f* f- 0e fmax IF fnegate THEN
    fdup motion f! fdup f0<> IF  xt execute  ELSE  fdrop  THEN
    -100 old ! ;

previous

    v0 colors'
    ascii-tex
    GL_TRIANGLES draw-elements
    sync
    2drop \ ntime d- dnegate ." Frame time: " d. cr
    >looper
    *input >r r@ IF
	r@ action @ 2 = IF
	    \ ." Touch at " r@ x0 ? r@ y0 ? cr
	    \ r@ x0 @ 20 < r@ y0 @ 20 < and IF -1 (bye) THEN
	    r@ x0 @ dpy-w @ 2/ - s>f dpy-h @ 2/ fm/
	    r@ y0 @ dpy-h @ 2/ - s>f dpy-h @ 2/ fm/
	    fover fover fnegate -0.15e lightpos glUniform3f
	    fatan2
	    touch f@ -100e f= IF
................................................................................
	    ambient% sf@ 0.05e f- 0.5e fmax ambient% sf!
	ELSE
	    ambient% sf@ 0.05e f+ 1.0e fmin ambient% sf!
	    angle motion f@ f+ to angle
	    motion f@ 0.01e f- 0.95e f* 0.01e f+ motion f!
	    -100e touch f!
	THEN
	." Motion: " motion f@ f. cr 0 -1 at-deltaxy
	r@ action off
    THEN
    rdrop angle ;

: tri-loop ( -- ) 1 level# +! 0e  BEGIN draw-tri level# @ 0= UNTIL fdrop ;

: gl-sample ( -- )
    ['] VertexShader ['] FragmentShader create-program to program
    program init load-textures .info
    tri-loop ;

previous previous



gl-sample

    v0 colors'
    ascii-tex
    GL_TRIANGLES draw-elements
    sync
    2drop \ ntime d- dnegate ." Frame time: " d. cr
    >looper
    *input >r r@ IF
	r@ pressure @ 0> IF
	    \ ." Touch at " r@ x0 ? r@ y0 ? cr
	    \ r@ x0 @ 20 < r@ y0 @ 20 < and IF -1 (bye) THEN
	    r@ x0 @ dpy-w @ 2/ - s>f dpy-h @ 2/ fm/
	    r@ y0 @ dpy-h @ 2/ - s>f dpy-h @ 2/ fm/
	    fover fover fnegate -0.15e lightpos glUniform3f
	    fatan2
	    touch f@ -100e f= IF
................................................................................
	    ambient% sf@ 0.05e f- 0.5e fmax ambient% sf!
	ELSE
	    ambient% sf@ 0.05e f+ 1.0e fmin ambient% sf!
	    angle motion f@ f+ to angle
	    motion f@ 0.01e f- 0.95e f* 0.01e f+ motion f!
	    -100e touch f!
	THEN
	\ ." Motion: " motion f@ f. cr 0 -1 at-deltaxy

    THEN
    rdrop angle ;

: tri-loop ( -- ) 1 level# +! 0e  BEGIN draw-tri level# @ 0= UNTIL fdrop ;

: gl-sample ( -- ) [IFDEF] hidekb  hidekb [THEN]
    ['] VertexShader ['] FragmentShader create-program to program
    program init load-textures .info
    tri-loop ;

previous previous

win 0= [IF] window-init [THEN]

gl-sample

	    pi f* fcos 1e f- [ pi f2/ fnegate ] FLiteral f* fcos 1e f-
	    fdup n1 n2 < IF fnegate  THEN yshift n1 draw-slide
	    2e f+ n1 n2 < IF fnegate  THEN yshift n2 draw-slide
	    draw-slide>  REPEAT
    <draw-slide n2 draw-slide draw-slide>
    fdrop ;

: slideshow-init ( -- ) recompile-shaders
    ['] VertexShader ['] FragmentShader create-program to program program init
    unit-matrix MVPMatrix set-matrix  buffer-init ;

Variable current-slide

: prefetch ( -- )
    current-slide @ 1+ slidelist $[]# 1- min read-in
    current-slide @ 1- 0 max read-in ;
: prefetch-thumb ( -- ) ;
................................................................................

: thumb-slide ( n -- ) +slide
    <draw-slide current-slide @ draw-thumbs draw-slide> ;

: thumb-yr ( -- float )  current-slide @ thumb# / s>f
    y-pos sf@ f2/ thumb# fm* f+ ;

: thumb-scroll ( r -- )  fdup floor fdup f>s thumb# * current-slide ! f-
    f2* thumb# fm/ >y-pos  0 thumb-slide ;

: +thumb-slide ( delta -- )
    thumb-yr f+ slidelist $[]# thumb# / 1 - s>f fmin
    0e fmax thumb-scroll ;
 


: slide-input ( -- )
    >looper
    *input >r r@ IF
	case  r@ action @  r@ action on
	    1 ( AMOTION_EVENT_ACTION_UP ) of
		short? IF
		    3 3 click-regions
		    BEGIN
			2dup 1 0 d= IF  2drop -1 +slide 1e  vslide  LEAVE  THEN
................................................................................
		THEN
	    endof
	    0 of  !click  endof
	endcase
    THEN
    rdrop ;

: reshow ( -- ) [IFDEF] android  kbflag @ IF  togglekb  THEN [THEN] 0e >y-pos
    slideshow-init <draw-slide current-slide @ draw-slide draw-slide>
    1 level# +! BEGIN  prefetch slide-input  level# @ 0= UNTIL ;




: thumb-input ( -- )
    ekey? IF  ekey case
	    k-up    of  [ thumb# dup * negate ]L thumb-slide  endof
	    k-down  of  [ thumb# dup *        ]L thumb-slide  endof
	endcase
    THEN
    >looper
    *input >r r@ IF
	case  r@ action @  r@ action on
	    1 ( AMOTION_EVENT_ACTION_UP ) of
		short? IF
		    thumb# dup click-regions
		    thumb# * + current-slide +!
		    -1 level# +!  reshow  1 level# +!
		    0 thumb-slide
		THEN
	    endof
	    0 of  !click  r@ y0 @ last-y0 !  endof
	    2 of
		thumb# r@ y0 @ last-y0 motion-y0 ['] +thumb-slide do-motion
		2drop
	    endof
	    last-y0 motion-y0 ['] +thumb-slide drag-motion
	endcase
    THEN
    rdrop ;

: rethumb ( -- ) [IFDEF] android  kbflag @ IF  togglekb  THEN [THEN] 0e >y-pos

	    pi f* fcos 1e f- [ pi f2/ fnegate ] FLiteral f* fcos 1e f-
	    fdup n1 n2 < IF fnegate  THEN yshift n1 draw-slide
	    2e f+ n1 n2 < IF fnegate  THEN yshift n2 draw-slide
	    draw-slide>  REPEAT
    <draw-slide n2 draw-slide draw-slide>
    fdrop ;

: slideshow-init ( -- )  ctx 0= IF  helper-init  THEN
    ['] VertexShader ['] FragmentShader create-program to program program init
    unit-matrix MVPMatrix set-matrix ;

Variable current-slide

: prefetch ( -- )
    current-slide @ 1+ slidelist $[]# 1- min read-in
    current-slide @ 1- 0 max read-in ;
: prefetch-thumb ( -- ) ;
................................................................................

: thumb-slide ( n -- ) +slide
    <draw-slide current-slide @ draw-thumbs draw-slide> ;

: thumb-yr ( -- float )  current-slide @ thumb# / s>f
    y-pos sf@ f2/ thumb# fm* f+ ;

: thumb-scroll ( r -- ) fdup floor fdup f>s thumb# * current-slide ! f-
    f2* thumb# fm/ >y-pos  0 thumb-slide ;

: +thumb-slide ( delta -- )
    thumb-yr f+ slidelist $[]# thumb# / 1 - s>f fmin
    0e fmax thumb-scroll 2drop ;

: ?esc ( -- )  key? IF  key #esc = IF  -1 level# +!  THEN  THEN ;

: slide-input ( -- )
    >looper ?esc
    *input >r r@ IF
	case  r@ action @  r@ action on
	    1 ( AMOTION_EVENT_ACTION_UP ) of
		short? IF
		    3 3 click-regions
		    BEGIN
			2dup 1 0 d= IF  2drop -1 +slide 1e  vslide  LEAVE  THEN
................................................................................
		THEN
	    endof
	    0 of  !click  endof
	endcase
    THEN
    rdrop ;

: (reshow) ( -- )
    0e >y-pos <draw-slide current-slide @ draw-slide draw-slide>
    1 level# +! BEGIN  prefetch slide-input  level# @ 0= UNTIL ;

: reshow ( -- ) [IFDEF] android  kbflag @ IF  togglekb  THEN [THEN]
    slideshow-init (reshow) ;

: thumb-input ( -- )
    ekey? IF  ekey case
	    k-up    of  [ thumb# dup * negate ]L thumb-slide  endof
	    k-down  of  [ thumb# dup *        ]L thumb-slide  endof
	endcase
    THEN
    >looper ?esc
    *input >r r@ IF
	case  r@ action @  r@ action on
	    1 ( AMOTION_EVENT_ACTION_UP ) of
		short? IF
		    thumb# dup click-regions
		    thumb# * + current-slide +!
		    -1 level# +!  (reshow)  1 level# +!
		    0 thumb-slide
		THEN
	    endof
	    0 of  !click  r@ y0 @ last-y0 !  endof
	    2 of
		thumb# r@ y0 @ last-y0 motion-y0 ['] +thumb-slide do-motion

	    endof
	    last-y0 motion-y0 ['] +thumb-slide drag-motion
	endcase
    THEN
    rdrop ;

: rethumb ( -- ) [IFDEF] android  kbflag @ IF  togglekb  THEN [THEN] 0e >y-pos

require ansi.fs \ we may want to support colorize.fs

\ opengl common stuff

require gl-helper.fs

[IFDEF] android  also android [THEN]

GL_FRAGMENT_SHADER shader: TerminalShader
#precision
uniform vec3 u_LightPos;        // The position of the light in eye space.
uniform sampler2D u_Texture;    // The input texture.
uniform float u_Ambient;        // ambient lighting level
uniform sampler2D u_Charmap;    // The character map
................................................................................
    count s>f $FF fm/
    count s>f $FF fm/
    count s>f $FF fm/
    c@    s>f $FF fm/ glClearColor ;

: std-bg! ( index -- )  dup bg! dup std-bg ! bg>clear ;

7 std-bg! 0 fg!



128 Value videocols
1   Value videorows

2Variable gl-xy  0 0 gl-xy 2!
2Variable gl-wh 24 80 gl-wh 2!
Variable gl-lineend
Variable scroll-y
FVariable scroll-dest
FVariable scroll-source
FVariable scroll-time

: ftime ( -- r ) ntime d>f 1e-9 f* ;

: form-chooser ( -- )
    dpy-w @ dpy-h @ > IF  24 80  ELSE  40 48  THEN  gl-wh 2! ;

: show-rows ( -- n ) videorows scroll-y @ - rows 1+ min ;
: nextpow2 ( n -- n' )
    1 BEGIN  2dup u>  WHILE 2*  REPEAT  nip ;

................................................................................

    v0 >rectangle >texcoords
    GL_TEXTURE0 glActiveTexture
    chars-tex
    i0 0 i, 1 i, 2 i, 0 i, 2 i, 3 i,
    GL_TRIANGLES draw-elements ;

: >x-pos ( r -- ) x-pos sf!  unit-matrix MVPMatrix set-matrix ;
: >y-pos ( r -- ) y-pos sf!  unit-matrix MVPMatrix set-matrix ;

: screen-scroll ( r -- )  fdup floor fdup f>s scroll-y ! f-
    f2* rows fm/ >y-pos  need-sync on ;

: gl-char' ( -- addr )
    gl-xy 2@ videocols * + sfloats videomem + ;

: gl-form ( -- h w ) gl-wh 2@ ;
................................................................................
    getwh  >screen-orientation
    need-sync on ;
\    ." config changed to: " w ? h ? cr

\ Google is stupid: This event comes too early
\ Make Gforth sync the screen up to four times till the config really changes
:noname

    4 0 DO  dpy-w @ dpy-h @ config-changer dpy-w @ dpy-h @ d<> screen-sync ?LEAVE LOOP

    config-changer form-chooser screen-sync ;
is config-changed

Variable last-x0  -100 last-x0 !
Variable last-y0  -100 last-y0 !
FVariable motion-x0
FVariable motion-y0

: scroll-yr ( -- float )  scroll-y @ s>f
    y-pos sf@ f2/ rows fm* f+ ;

: +scroll ( -- )
    scroll-yr f+ videorows 1 - s>f fmin
    0e fmax screen-scroll ;

0.5e FConstant rel-drag
0.3e FConstant abs-drag
FVariable drag-time
: f!@ ( r1 addr -- r2 ) dup f@ fswap f! ;
: delta-t ( -- r )
    ftime fdup drag-time f!@ f- fdup 1e f> IF  fdrop 0e  THEN ;

Fvariable click-time
0.15e FConstant short-click#
0.5e  FConstant long-click#

: delta-tc  ftime click-time f@ f- ;
: short? ( -- flag )
    delta-tc short-click# f< ;
: long? ( -- flag )
    delta-tc long-click# f> ;
: !click ( -- ) ftime click-time f! ;
[IFUNDEF] togglekb : togglekb ; [THEN]
: ?toggle ( -- )
    short? motion-y0 f@ f0= and IF  togglekb need-show off  THEN ;

: do-motion { rows cur old motion xt -- }
    old @ -100 = IF
	cur old !
    ELSE
	cur old @ over old ! swap -
	s>f dpy-h @ s>f rows fm/ f/ fdup motion f! xt execute
    THEN ;

: drag-motion { old motion xt -- } delta-t { f: dt }
    motion f@ rel-drag dt f** f*
    fdup f0< fabs abs-drag dt f* f- 0e fmax IF fnegate THEN
    fdup motion f! fdup f0<> IF  xt execute  ELSE  fdrop  THEN
    -100 old ! ;

: screen-slide ( -- )
    *input >r
    r@ IF
	r@ action @ \ dup -1 <> IF  dup . delta-t f. cr  THEN
	case  2 of
		rows r@ y0 @ last-y0 motion-y0 ['] +scroll do-motion
		long? IF  kbflag @ IF  togglekb  THEN  THEN
................................................................................

: term-init ( -- )
    >screen-orientation
    create-terminal-program to terminal-program
    terminal-program terminal-init term-load-textures form-chooser
    unit-matrix MVPMatrix set-matrix ;

:noname  defers window-init ['] TerminalShader recompile-shader
    term-init config-changer ; IS window-init

window-init

previous \ remove opengl from search order
[IFDEF] android  previous  [THEN]

require ansi.fs \ we may want to support colorize.fs

\ opengl common stuff

require gl-helper.fs

also [IFDEF] android android [THEN]

GL_FRAGMENT_SHADER shader: TerminalShader
#precision
uniform vec3 u_LightPos;        // The position of the light in eye space.
uniform sampler2D u_Texture;    // The input texture.
uniform float u_Ambient;        // ambient lighting level
uniform sampler2D u_Charmap;    // The character map
................................................................................
    count s>f $FF fm/
    count s>f $FF fm/
    count s>f $FF fm/
    c@    s>f $FF fm/ glClearColor ;

: std-bg! ( index -- )  dup bg! dup std-bg ! bg>clear ;

: >white White std-bg! Black fg! ;
: >black Black std-bg! White fg! ;
>white

128 Value videocols
1   Value videorows

2Variable gl-xy  0 0 gl-xy 2!
2Variable gl-wh 24 80 gl-wh 2!
Variable gl-lineend
Variable scroll-y
FVariable scroll-dest
FVariable scroll-source
FVariable scroll-time



: form-chooser ( -- )
    dpy-w @ dpy-h @ > IF  24 80  ELSE  40 48  THEN  gl-wh 2! ;

: show-rows ( -- n ) videorows scroll-y @ - rows 1+ min ;
: nextpow2 ( n -- n' )
    1 BEGIN  2dup u>  WHILE 2*  REPEAT  nip ;

................................................................................

    v0 >rectangle >texcoords
    GL_TEXTURE0 glActiveTexture
    chars-tex
    i0 0 i, 1 i, 2 i, 0 i, 2 i, 3 i,
    GL_TRIANGLES draw-elements ;




: screen-scroll ( r -- )  fdup floor fdup f>s scroll-y ! f-
    f2* rows fm/ >y-pos  need-sync on ;

: gl-char' ( -- addr )
    gl-xy 2@ videocols * + sfloats videomem + ;

: gl-form ( -- h w ) gl-wh 2@ ;
................................................................................
    getwh  >screen-orientation
    need-sync on ;
\    ." config changed to: " w ? h ? cr

\ Google is stupid: This event comes too early
\ Make Gforth sync the screen up to four times till the config really changes
:noname
    [IFDEF] android 4 [ELSE] 1 [THEN] 0 DO
	dpy-w @ dpy-h @ config-changer dpy-w @ dpy-h @ d<> screen-sync ?LEAVE
    LOOP
    config-changer form-chooser screen-sync ;
is config-changed






: scroll-yr ( -- float )  scroll-y @ s>f
    y-pos sf@ f2/ rows fm* f+ ;

: +scroll ( -- )
    scroll-yr f+ videorows 1 - s>f fmin
    0e fmax screen-scroll ;




































: screen-slide ( -- )
    *input >r
    r@ IF
	r@ action @ \ dup -1 <> IF  dup . delta-t f. cr  THEN
	case  2 of
		rows r@ y0 @ last-y0 motion-y0 ['] +scroll do-motion
		long? IF  kbflag @ IF  togglekb  THEN  THEN
................................................................................

: term-init ( -- )
    >screen-orientation
    create-terminal-program to terminal-program
    terminal-program terminal-init term-load-textures form-chooser
    unit-matrix MVPMatrix set-matrix ;


:noname  defers window-init term-init config-changer ; IS window-init

window-init

previous previous \ remove opengl from search order

	APP_CMD_START of [: ." app start" cr ;] $err endof
	APP_CMD_STOP of [: ." app stop" cr ;] $err endof
	dup [: ." app cmd " . cr ;] $err
    endcase ; is acmd

also jni

:noname ( event type -- )
    >o
    getAction dup 2 = IF  drop ."
	getKeyCode dup 0= IF
	    drop getCharacters jstring>sstring unkeys jfree
	ELSE
	    keycode>keys unkeys
	THEN
    ELSE
	0= IF  getUnicodeChar dup 0>
	    IF    >xstring unkeys
	    ELSE  drop  getKeyCode  keycode>keys  unkeys
	    THEN
	THEN
    THEN o> ; is akey














previous previous set-current

	APP_CMD_START of [: ." app start" cr ;] $err endof
	APP_CMD_STOP of [: ." app stop" cr ;] $err endof
	dup [: ." app cmd " . cr ;] $err
    endcase ; is acmd

also jni

: android-key ( event -- )

    >o getAction dup 2 = IF  drop ."
	getKeyCode dup 0= IF
	    drop getCharacters jstring>sstring unkeys jfree
	ELSE
	    keycode>keys unkeys
	THEN
    ELSE
	0= IF  getUnicodeChar dup 0>
	    IF    >xstring unkeys
	    ELSE  drop  getKeyCode  keycode>keys  unkeys
	    THEN
	THEN
    THEN o> ;

Defer android-touch ( event -- )
' drop IS android-touch

Defer android-location ( location -- )
' drop IS android-location

:noname ( event type -- )
    CASE
	0 OF  android-key       ENDOF
	1 OF  android-touch     ENDOF
	2 OF  android-location  ENDOF
    ENDCASE  drop ; is akey

previous previous set-current

\ freetype GL example

\ needs wide char arguments

Variable wide$
Variable widec


: >wide$ ( addr u -- addr' u' )  s" " wide$ $!
    over + swap ?DO
        I xc@+ widec l! widec 4 wide$ $+!
    I - +LOOP  wide$ $@ ;

\ freetype stuff

require freetype-gl.fs

also freetype-gl
also opengl
................................................................................
    fover f- fnegate fd fmin fswap fh fmax ;

: layout-string ( addr u -- fw fh fd ) \ depth is ow far it goes down
    0 -rot  0e 0e 0e  bounds ?DO
	I xc@+ swap >r xchar@xy r>
    I - +LOOP  drop ;

: load-glyphs ( -- )
    font


    "#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_`abcdefghijklmnopqrstuvwxyz{|}~\0" >wide$ drop texture_font_load_glyphs drop ;

program init

: <render ( -- )
    program glUseProgram
    1-bias set-color+
    .01e 100e 100e >ap
    atlas-tex v0 i0 ;

: render> ( -- )  GL_TRIANGLES draw-elements
    ( Coloradd 0e fdup fdup fdup glUniform4f ) ;

previous previous

\ freetype GL example

\ needs wide char arguments

Variable wide$
Variable widec

: >widec ( char -- ) widec l! widec 4 wide$ $+! ;
: >wide$ ( addr u -- addr' )  s" " wide$ $!

    bounds ?DO  I xc@+ >widec  I - +LOOP  0 >widec  wide$ $@ drop ;


\ freetype stuff

require freetype-gl.fs

also freetype-gl
also opengl
................................................................................
    fover f- fnegate fd fmin fswap fh fmax ;

: layout-string ( addr u -- fw fh fd ) \ depth is ow far it goes down
    0 -rot  0e 0e 0e  bounds ?DO
	I xc@+ swap >r xchar@xy r>
    I - +LOOP  drop ;

: load-glyph$ ( addr u -- ) >wide$
    font swap texture_font_load_glyphs drop ;

: load-ascii ( -- )
    "#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_`abcdefghijklmnopqrstuvwxyz{|}~" load-glyph$ ;

program init

: <render ( -- )
    program glUseProgram
    1-bias set-color+
    .01e 100e 100e >ap
    atlas-tex v0 i0 ;

: render> ( -- )  GL_TRIANGLES draw-elements
    ( Coloradd 0e fdup fdup fdup glUniform4f ) ;

previous previous

\ opengl common stuff

require unix/mmap.fs
require mini-oof2.fs

: w, ( n -- )  here 2 allot w! ;
: l, ( n -- )  here 4 allot l! ;





s" os-type" environment? [IF]
    2dup s" linux-android" str= [IF] 2drop
	require opengl.fs
	
	also opengl
	
................................................................................
	    s" precision mediump float;        // required for GLES 2.0" ;
    [ELSE]
	s" linux-gnu" str= [IF]
	    require opengl/opengl.fs
	    
	    also opengl
	
	    require opengl/linux.fs
	    also \ same voc stack effect as on android

	    align here
	    GLX_SAMPLE_BUFFERS  l, 1 l,
	    GLX_SAMPLES         l, 4 l,
	    here
	    GLX_RED_SIZE        l, 8 l,
	    GLX_GREEN_SIZE      l, 8 l,
................................................................................
	: add-precision s" " ;
    [THEN]
[THEN]

Variable configs
Variable numconfigs
Variable eglformat
Variable dpy-w
Variable dpy-h

: ??gl .s ." gl: " glGetError . ; ' ??gl is printdebugdata

[IFDEF] android
    : win app window @ ;
    
    0 Value egldpy
    0 Value surface
    0 Value eglcontext
    
    : getwh ( -- )
	egldpy surface EGL_WIDTH dpy-w eglQuerySurface drop
	egldpy surface EGL_HEIGHT dpy-h eglQuerySurface drop
	0 0 dpy-w @ dpy-h @ glViewport ;

    : >screen-orientation ( -- )
................................................................................
		." default config only" EXIT
	    THEN
	THEN ;
    
    : create-context ( -- )
	win 0 0 eglformat ANativeWindow_setBuffersGeometry drop
	egldpy configs @ win 0 eglCreateWindowSurface to surface
	egldpy configs @ 0 eglattribs eglCreateContext to eglcontext
	egldpy surface dup eglcontext eglMakeCurrent drop ;

    : sync ( -- )
	egldpy surface eglSwapBuffers drop ;
[THEN]

[IFDEF] linux
    fpath+ gles2
    0 Value visual
    0 Value ctx

    \ I have no luck with glXChooseVisual - this is a replacement:
    Variable nitems
    Variable val
    : glXVisual? ( visinfo attrib -- flag ) true { flag }
	BEGIN  dup l@  WHILE
		2dup dpy -rot l@ val glXGetConfig drop
................................................................................
	REPEAT  2drop flag ;
    
    : glXChooseVisual' ( dpy screen attrib -- ) { attrib }
	pad nitems XGetVisualInfo nitems @ XVisualInfo * bounds ?DO
	    I attrib glXVisual?  IF  I unloop  EXIT  THEN
	XVisualInfo +LOOP 0 ;
    
    : choose-config ( -- )
	get-display dpy-h ! dpy-w !
	dpy screen attrib3 glXChooseVisual' dup 0= IF  drop
	    dpy screen attrib2 glXChooseVisual' dup 0= IF  drop
		dpy screen attrib glXChooseVisual' dup
		0= abort" Unable to choose Visual"
	    THEN
	THEN  to visual ;

    : create-context ( -- )
	default-events "GL-Window\0" drop dpy-w @ dpy-h @ simple-win
	dpy visual 0 1 glXCreateContext to ctx
	dpy win ctx glXMakeCurrent drop ;

    : getwh ( -- )
	0 0 dpy-w @ dpy-h @ glViewport ;

    : >screen-orientation ;

    : sync ( -- )
	dpy win glXSwapBuffers ;
[THEN]

: init-opengl ( -- )
................................................................................
0 Value LightPos
0 Value Texture
0 Value ambient
0 Value Coloradd
0 Value program

: create-program { vs-xt fs-xt -- program }


    glCreateProgram dup >r IF
	r@ vs-xt execute glAttachShader
	r@ fs-xt execute glAttachShader
	vs-xt r@ >bindattrib
	r@ glLinkProgram THEN
    r> ;

................................................................................
	I 4 sfloats bounds DO
	    I sf@ f.
	1 sfloats +LOOP cr
    4 sfloats +LOOP ;

: set-matrix ( addr handle -- ) swap >r
    1 false r> glUniformMatrix4fv ;




: set-color+ ( addr -- )  Coloradd 1 rot glUniform4fv ;

: >ortho { f: near f: far f: left f: right f: top f: bottom -- }
    ap-matrix
    near f2* right left f- f/ sf!+ 0e sf!+ 0e sf!+ 0e sf!+
    0e sf!+ near f2* top bottom f- f/ sf!+ 0e sf!+ 0e sf!+
................................................................................
: f>c ( r g b a -- )  c.a sf! c.b sf! c.g sf! c.r sf! ;
: n>xyz ( x y z -- ) n.z sf! n.y sf! n.x sf! 1e n.t sf! ;
: n> ( -- ) -1e n.z sf! 0e n.y sf! 0e n.x sf! 1e n.t sf! ;
: >st ( s t -- ) t.t sf! t.s sf! ;

\ window closed/reopened

: recompile-shaders ( -- )
    ['] VertexShader recompile-shader
    ['] FragmentShader recompile-shader ;

: helper-init  init-opengl texture-init recompile-shaders
    ['] VertexShader ['] FragmentShader create-program to program
    program init  buffer-init ;

:noname  defers window-init helper-init ; IS window-init

\ click region stuff

: click-regions ( w h -- x' y' )  >r >r
    *input x0 @ r> dpy-w @ */
    *input y0 @ r> dpy-h @ */ ;












































previous

\ opengl common stuff

require unix/mmap.fs
require mini-oof2.fs

: w, ( n -- )  here 2 allot w! ;
: l, ( n -- )  here 4 allot l! ;

Variable dpy-w
Variable dpy-h
0 Value ctx

s" os-type" environment? [IF]
    2dup s" linux-android" str= [IF] 2drop
	require opengl.fs
	
	also opengl
	
................................................................................
	    s" precision mediump float;        // required for GLES 2.0" ;
    [ELSE]
	s" linux-gnu" str= [IF]
	    require opengl/opengl.fs
	    
	    also opengl
	

	    require opengl/linux.fs \ same voc stack effect as on android

	    align here
	    GLX_SAMPLE_BUFFERS  l, 1 l,
	    GLX_SAMPLES         l, 4 l,
	    here
	    GLX_RED_SIZE        l, 8 l,
	    GLX_GREEN_SIZE      l, 8 l,
................................................................................
	: add-precision s" " ;
    [THEN]
[THEN]

Variable configs
Variable numconfigs
Variable eglformat



: ??gl .s ." gl: " glGetError . ; ' ??gl is printdebugdata

[IFDEF] android
    : win app window @ ;
    
    0 Value egldpy
    0 Value surface

    
    : getwh ( -- )
	egldpy surface EGL_WIDTH dpy-w eglQuerySurface drop
	egldpy surface EGL_HEIGHT dpy-h eglQuerySurface drop
	0 0 dpy-w @ dpy-h @ glViewport ;

    : >screen-orientation ( -- )
................................................................................
		." default config only" EXIT
	    THEN
	THEN ;
    
    : create-context ( -- )
	win 0 0 eglformat ANativeWindow_setBuffersGeometry drop
	egldpy configs @ win 0 eglCreateWindowSurface to surface
	egldpy configs @ 0 eglattribs eglCreateContext to ctx
	egldpy surface dup ctx eglMakeCurrent drop ;

    : sync ( -- )
	egldpy surface eglSwapBuffers drop ;
[THEN]

[IFDEF] linux
    fpath+ gles2
    0 Value visual


    \ I have no luck with glXChooseVisual - this is a replacement:
    Variable nitems
    Variable val
    : glXVisual? ( visinfo attrib -- flag ) true { flag }
	BEGIN  dup l@  WHILE
		2dup dpy -rot l@ val glXGetConfig drop
................................................................................
	REPEAT  2drop flag ;
    
    : glXChooseVisual' ( dpy screen attrib -- ) { attrib }
	pad nitems XGetVisualInfo nitems @ XVisualInfo * bounds ?DO
	    I attrib glXVisual?  IF  I unloop  EXIT  THEN
	XVisualInfo +LOOP 0 ;
    
    : choose-config ( -- ) \ visual ?EXIT
	get-display dpy-h ! dpy-w !
	dpy screen attrib3 glXChooseVisual' dup 0= IF  drop
	    dpy screen attrib2 glXChooseVisual' dup 0= IF  drop
		dpy screen attrib glXChooseVisual' dup
		0= abort" Unable to choose Visual"
	    THEN
	THEN  to visual ;

    : create-context ( -- ) \ win ?EXIT
	default-events "GL-Window\0" drop dpy-w @ dpy-h @ simple-win
	dpy visual 0 1 glXCreateContext to ctx
	dpy win ctx glXMakeCurrent drop ;




    : >screen-orientation ;

    : sync ( -- )
	dpy win glXSwapBuffers ;
[THEN]

: init-opengl ( -- )
................................................................................
0 Value LightPos
0 Value Texture
0 Value ambient
0 Value Coloradd
0 Value program

: create-program { vs-xt fs-xt -- program }
    vs-xt recompile-shader
    fs-xt recompile-shader
    glCreateProgram dup >r IF
	r@ vs-xt execute glAttachShader
	r@ fs-xt execute glAttachShader
	vs-xt r@ >bindattrib
	r@ glLinkProgram THEN
    r> ;

................................................................................
	I 4 sfloats bounds DO
	    I sf@ f.
	1 sfloats +LOOP cr
    4 sfloats +LOOP ;

: set-matrix ( addr handle -- ) swap >r
    1 false r> glUniformMatrix4fv ;

: >x-pos ( r -- ) x-pos sf!  unit-matrix MVPMatrix set-matrix ;
: >y-pos ( r -- ) y-pos sf!  unit-matrix MVPMatrix set-matrix ;

: set-color+ ( addr -- )  Coloradd 1 rot glUniform4fv ;

: >ortho { f: near f: far f: left f: right f: top f: bottom -- }
    ap-matrix
    near f2* right left f- f/ sf!+ 0e sf!+ 0e sf!+ 0e sf!+
    0e sf!+ near f2* top bottom f- f/ sf!+ 0e sf!+ 0e sf!+
................................................................................
: f>c ( r g b a -- )  c.a sf! c.b sf! c.g sf! c.r sf! ;
: n>xyz ( x y z -- ) n.z sf! n.y sf! n.x sf! 1e n.t sf! ;
: n> ( -- ) -1e n.z sf! 0e n.y sf! 0e n.x sf! 1e n.t sf! ;
: >st ( s t -- ) t.t sf! t.s sf! ;

\ window closed/reopened





: helper-init  init-opengl texture-init
    ['] VertexShader ['] FragmentShader create-program to program
    program init  buffer-init ;

:noname  defers window-init helper-init ; IS window-init

\ click region stuff

: click-regions ( w h -- x' y' )  >r >r
    *input x0 @ r> dpy-w @ */
    *input y0 @ r> dpy-h @ */ ;

\ toggle and drag time stuff

: ftime ( -- r ) ntime d>f 1e-9 f* ;

0.5e FConstant rel-drag
0.3e FConstant abs-drag
FVariable drag-time
: f!@ ( r1 addr -- r2 ) dup f@ fswap f! ;
: delta-t ( -- r )
    ftime fdup drag-time f!@ f- fdup 1e f> IF  fdrop 0e  THEN ;

Fvariable click-time
FVariable motion-x0
FVariable motion-y0
Variable last-x0  -100 last-x0 !
Variable last-y0  -100 last-y0 !
0.15e FConstant short-click#
0.5e  FConstant long-click#

: delta-tc  ftime click-time f@ f- ;
: short? ( -- flag )
    delta-tc short-click# f< ;
: long? ( -- flag )
    delta-tc long-click# f> ;
: !click ( -- ) ftime click-time f! ;
[IFUNDEF] togglekb : togglekb ; [THEN]
: ?toggle ( -- )
    short? motion-y0 f@ f0= and IF  togglekb need-show off  THEN ;

: do-motion { rows cur old motion xt -- }
    old @ -100 = IF
	cur old !
    ELSE
	cur old @ over old ! swap -
	s>f dpy-h @ s>f rows fm/ f/ fdup motion f! xt execute
    THEN ;

: drag-motion { old motion xt -- } delta-t { f: dt }
    motion f@ rel-drag dt f** f*
    fdup f0< fabs abs-drag dt f* f- 0e fmax IF fnegate THEN
    fdup motion f! fdup f0<> IF  xt execute  ELSE  fdrop  THEN
    -100 old ! ;

previous

    v0 colors'
    ascii-tex
    GL_TRIANGLES draw-elements
    sync
    2drop \ ntime d- dnegate ." Frame time: " d. cr
    >looper
    *input >r r@ IF
	r@ action @ 2 = IF
	    \ ." Touch at " r@ x0 ? r@ y0 ? cr
	    \ r@ x0 @ 20 < r@ y0 @ 20 < and IF -1 (bye) THEN
	    r@ x0 @ dpy-w @ 2/ - s>f dpy-h @ 2/ fm/
	    r@ y0 @ dpy-h @ 2/ - s>f dpy-h @ 2/ fm/
	    fover fover fnegate -0.15e lightpos glUniform3f
	    fatan2
	    touch f@ -100e f= IF
................................................................................
	    ambient% sf@ 0.05e f- 0.5e fmax ambient% sf!
	ELSE
	    ambient% sf@ 0.05e f+ 1.0e fmin ambient% sf!
	    angle motion f@ f+ to angle
	    motion f@ 0.01e f- 0.95e f* 0.01e f+ motion f!
	    -100e touch f!
	THEN
	." Motion: " motion f@ f. cr 0 -1 at-deltaxy
	r@ action off
    THEN
    rdrop angle ;

: tri-loop ( -- ) 1 level# +! 0e  BEGIN draw-tri level# @ 0= UNTIL fdrop ;

: gl-sample ( -- )
    ['] VertexShader ['] FragmentShader create-program to program
    program init load-textures .info
    tri-loop ;

previous previous



gl-sample

    v0 colors'
    ascii-tex
    GL_TRIANGLES draw-elements
    sync
    2drop \ ntime d- dnegate ." Frame time: " d. cr
    >looper
    *input >r r@ IF
	r@ pressure @ 0> IF
	    \ ." Touch at " r@ x0 ? r@ y0 ? cr
	    \ r@ x0 @ 20 < r@ y0 @ 20 < and IF -1 (bye) THEN
	    r@ x0 @ dpy-w @ 2/ - s>f dpy-h @ 2/ fm/
	    r@ y0 @ dpy-h @ 2/ - s>f dpy-h @ 2/ fm/
	    fover fover fnegate -0.15e lightpos glUniform3f
	    fatan2
	    touch f@ -100e f= IF
................................................................................
	    ambient% sf@ 0.05e f- 0.5e fmax ambient% sf!
	ELSE
	    ambient% sf@ 0.05e f+ 1.0e fmin ambient% sf!
	    angle motion f@ f+ to angle
	    motion f@ 0.01e f- 0.95e f* 0.01e f+ motion f!
	    -100e touch f!
	THEN
	\ ." Motion: " motion f@ f. cr 0 -1 at-deltaxy

    THEN
    rdrop angle ;

: tri-loop ( -- ) 1 level# +! 0e  BEGIN draw-tri level# @ 0= UNTIL fdrop ;

: gl-sample ( -- ) [IFDEF] hidekb  hidekb [THEN]
    ['] VertexShader ['] FragmentShader create-program to program
    program init load-textures .info
    tri-loop ;

previous previous

win 0= [IF] window-init [THEN]

gl-sample

require ansi.fs \ we may want to support colorize.fs

\ opengl common stuff

require gl-helper.fs

[IFDEF] android  also android [THEN]

GL_FRAGMENT_SHADER shader: TerminalShader
#precision
uniform vec3 u_LightPos;        // The position of the light in eye space.
uniform sampler2D u_Texture;    // The input texture.
uniform float u_Ambient;        // ambient lighting level
uniform sampler2D u_Charmap;    // The character map
................................................................................
    count s>f $FF fm/
    count s>f $FF fm/
    count s>f $FF fm/
    c@    s>f $FF fm/ glClearColor ;

: std-bg! ( index -- )  dup bg! dup std-bg ! bg>clear ;

7 std-bg! 0 fg!



128 Value videocols
1   Value videorows

2Variable gl-xy  0 0 gl-xy 2!
2Variable gl-wh 24 80 gl-wh 2!
Variable gl-lineend
Variable scroll-y
FVariable scroll-dest
FVariable scroll-source
FVariable scroll-time

: ftime ( -- r ) ntime d>f 1e-9 f* ;

: form-chooser ( -- )
    dpy-w @ dpy-h @ > IF  24 80  ELSE  40 48  THEN  gl-wh 2! ;

: show-rows ( -- n ) videorows scroll-y @ - rows 1+ min ;
: nextpow2 ( n -- n' )
    1 BEGIN  2dup u>  WHILE 2*  REPEAT  nip ;

................................................................................

    v0 >rectangle >texcoords
    GL_TEXTURE0 glActiveTexture
    chars-tex
    i0 0 i, 1 i, 2 i, 0 i, 2 i, 3 i,
    GL_TRIANGLES draw-elements ;

: >x-pos ( r -- ) x-pos sf!  unit-matrix MVPMatrix set-matrix ;
: >y-pos ( r -- ) y-pos sf!  unit-matrix MVPMatrix set-matrix ;

: screen-scroll ( r -- )  fdup floor fdup f>s scroll-y ! f-
    f2* rows fm/ >y-pos  need-sync on ;

: gl-char' ( -- addr )
    gl-xy 2@ videocols * + sfloats videomem + ;

: gl-form ( -- h w ) gl-wh 2@ ;
................................................................................
    getwh  >screen-orientation
    need-sync on ;
\    ." config changed to: " w ? h ? cr

\ Google is stupid: This event comes too early
\ Make Gforth sync the screen up to four times till the config really changes
:noname

    4 0 DO  dpy-w @ dpy-h @ config-changer dpy-w @ dpy-h @ d<> screen-sync ?LEAVE LOOP

    config-changer form-chooser screen-sync ;
is config-changed

Variable last-x0  -100 last-x0 !
Variable last-y0  -100 last-y0 !
FVariable motion-x0
FVariable motion-y0

: scroll-yr ( -- float )  scroll-y @ s>f
    y-pos sf@ f2/ rows fm* f+ ;

: +scroll ( -- )
    scroll-yr f+ videorows 1 - s>f fmin
    0e fmax screen-scroll ;

0.5e FConstant rel-drag
0.3e FConstant abs-drag
FVariable drag-time
: f!@ ( r1 addr -- r2 ) dup f@ fswap f! ;
: delta-t ( -- r )
    ftime fdup drag-time f!@ f- fdup 1e f> IF  fdrop 0e  THEN ;

Fvariable click-time
0.15e FConstant short-click#
0.5e  FConstant long-click#

: delta-tc  ftime click-time f@ f- ;
: short? ( -- flag )
    delta-tc short-click# f< ;
: long? ( -- flag )
    delta-tc long-click# f> ;
: !click ( -- ) ftime click-time f! ;
[IFUNDEF] togglekb : togglekb ; [THEN]
: ?toggle ( -- )
    short? motion-y0 f@ f0= and IF  togglekb need-show off  THEN ;

: do-motion { rows cur old motion xt -- }
    old @ -100 = IF
	cur old !
    ELSE
	cur old @ over old ! swap -
	s>f dpy-h @ s>f rows fm/ f/ fdup motion f! xt execute
    THEN ;

: drag-motion { old motion xt -- } delta-t { f: dt }
    motion f@ rel-drag dt f** f*
    fdup f0< fabs abs-drag dt f* f- 0e fmax IF fnegate THEN
    fdup motion f! fdup f0<> IF  xt execute  ELSE  fdrop  THEN
    -100 old ! ;

: screen-slide ( -- )
    *input >r
    r@ IF
	r@ action @ \ dup -1 <> IF  dup . delta-t f. cr  THEN
	case  2 of
		rows r@ y0 @ last-y0 motion-y0 ['] +scroll do-motion
		long? IF  kbflag @ IF  togglekb  THEN  THEN
................................................................................

: term-init ( -- )
    >screen-orientation
    create-terminal-program to terminal-program
    terminal-program terminal-init term-load-textures form-chooser
    unit-matrix MVPMatrix set-matrix ;

:noname  defers window-init ['] TerminalShader recompile-shader
    term-init config-changer ; IS window-init

window-init

previous \ remove opengl from search order
[IFDEF] android  previous  [THEN]

require ansi.fs \ we may want to support colorize.fs

\ opengl common stuff

require gl-helper.fs

also [IFDEF] android android [THEN]

GL_FRAGMENT_SHADER shader: TerminalShader
#precision
uniform vec3 u_LightPos;        // The position of the light in eye space.
uniform sampler2D u_Texture;    // The input texture.
uniform float u_Ambient;        // ambient lighting level
uniform sampler2D u_Charmap;    // The character map
................................................................................
    count s>f $FF fm/
    count s>f $FF fm/
    count s>f $FF fm/
    c@    s>f $FF fm/ glClearColor ;

: std-bg! ( index -- )  dup bg! dup std-bg ! bg>clear ;

: >white White std-bg! Black fg! ;
: >black Black std-bg! White fg! ;
>white

128 Value videocols
1   Value videorows

2Variable gl-xy  0 0 gl-xy 2!
2Variable gl-wh 24 80 gl-wh 2!
Variable gl-lineend
Variable scroll-y
FVariable scroll-dest
FVariable scroll-source
FVariable scroll-time



: form-chooser ( -- )
    dpy-w @ dpy-h @ > IF  24 80  ELSE  40 48  THEN  gl-wh 2! ;

: show-rows ( -- n ) videorows scroll-y @ - rows 1+ min ;
: nextpow2 ( n -- n' )
    1 BEGIN  2dup u>  WHILE 2*  REPEAT  nip ;

................................................................................

    v0 >rectangle >texcoords
    GL_TEXTURE0 glActiveTexture
    chars-tex
    i0 0 i, 1 i, 2 i, 0 i, 2 i, 3 i,
    GL_TRIANGLES draw-elements ;




: screen-scroll ( r -- )  fdup floor fdup f>s scroll-y ! f-
    f2* rows fm/ >y-pos  need-sync on ;

: gl-char' ( -- addr )
    gl-xy 2@ videocols * + sfloats videomem + ;

: gl-form ( -- h w ) gl-wh 2@ ;
................................................................................
    getwh  >screen-orientation
    need-sync on ;
\    ." config changed to: " w ? h ? cr

\ Google is stupid: This event comes too early
\ Make Gforth sync the screen up to four times till the config really changes
:noname
    [IFDEF] android 4 [ELSE] 1 [THEN] 0 DO
	dpy-w @ dpy-h @ config-changer dpy-w @ dpy-h @ d<> screen-sync ?LEAVE
    LOOP
    config-changer form-chooser screen-sync ;
is config-changed






: scroll-yr ( -- float )  scroll-y @ s>f
    y-pos sf@ f2/ rows fm* f+ ;

: +scroll ( -- )
    scroll-yr f+ videorows 1 - s>f fmin
    0e fmax screen-scroll ;




































: screen-slide ( -- )
    *input >r
    r@ IF
	r@ action @ \ dup -1 <> IF  dup . delta-t f. cr  THEN
	case  2 of
		rows r@ y0 @ last-y0 motion-y0 ['] +scroll do-motion
		long? IF  kbflag @ IF  togglekb  THEN  THEN
................................................................................

: term-init ( -- )
    >screen-orientation
    create-terminal-program to terminal-program
    terminal-program terminal-init term-load-textures form-chooser
    unit-matrix MVPMatrix set-matrix ;


:noname  defers window-init term-init config-changer ; IS window-init

window-init

previous previous \ remove opengl from search order

require jni-tools.fs

also android also jni

app activity @ ANativeActivity-clazz @ dup Value clazz
env tuck JNIEnv-getObjectClass() to jniclass

jni-sfield: INPUT_METHOD_SERVICE INPUT_METHOD_SERVICE Ljava/lang/String;
jni-sfield: POWER_SERVICE POWER_SERVICE Ljava/lang/String;




jni-method: getSystemService getSystemService (Ljava/lang/String;)Ljava/lang/Object;
jni-method: getWindow getWindow ()Landroid/view/Window;

jni-class: android/app/Activity
jni-method: getWindowManager getWindowManager ()Landroid/view/WindowManager;

jni-class: android/view/WindowManager

require jni-tools.fs

also android also jni

app activity @ ANativeActivity-clazz @ dup Value clazz
env tuck JNIEnv-getObjectClass() to jniclass

\ jni-sfield: INPUT_METHOD_SERVICE INPUT_METHOD_SERVICE Ljava/lang/String;
\ jni-sfield: POWER_SERVICE POWER_SERVICE Ljava/lang/String;
: INPUT_METHOD_SERVICE js" input_method" ;
: POWER_SERVICE        js" power" ;
: LOCATION_SERVICE     js" location" ;

jni-method: getSystemService getSystemService (Ljava/lang/String;)Ljava/lang/Object;
jni-method: getWindow getWindow ()Landroid/view/Window;

jni-class: android/app/Activity
jni-method: getWindowManager getWindowManager ()Landroid/view/WindowManager;

jni-class: android/view/WindowManager

\ location services

also jni

jni-class: android/location/Location

jni-method: getAccuracy getAccuracy ()F
jni-method: getAltitude getAltitude ()D
jni-method: getBearing getBearing ()F
jni-method: getAltitude getAltitude ()D
jni-method: getLatitude getLatitude ()D
jni-method: getLongitude getLongitude ()D
jni-method: getProvider getProvider ()Ljava/lang/String;
jni-method: getSpeed getSpeed ()F
jni-method: getTime getTime ()J

jni-class: android/location/LocationManager

jni-method: getAllProviders getAllProviders ()Ljava/util/List;
jni-method: getProviders getProviders (Z)Ljava/util/List;
jni-method: getProvider getProvider (Ljava/lang/String;)Landroid/location/LocationProvider;
jni-method: requestLocationUpdates requestLocationUpdates (Ljava/lang/String;JFLandroid/location/LocationListener;)V
jni-method: getLastKnownLocation getLastKnownLocation (Ljava/lang/String;)Landroid/location/Location;
jni-method: removeUpdates removeUpdates (Landroid/location/LocationListener;)V


previous

#!/bin/bash

ENGINE=gforth-x32
KERNL=$(gforth-x32 --debug -e bye 2>&1 |grep "Opened image file: "|sed -e 's/Opened image file: //g' -e 's/gforth.fi/kernl*.fi/g')
VERSION=$($ENGINE --version 2>&1 | tr ' ' '/')
srcdir=.
DESTDIR=/home/bernd/proj/net2o
prefix= 
ARCH=""
exec_prefix=${prefix}
libexecdir=$package${exec_prefix}/lib
libccdir=$libexecdir/$VERSION/libcc-named/
LIBRARY="opengl.fs android.fs png.fs soillib.fs openmax.fs jni.fs freetype-gl.fs" #  openvglib.fs
ANDROID=${ANDROID-~/proj/gforths/gforth-android}

for i in $LIBRARY
do
    echo "generating library $i"
    $ENGINE -i $KERNL -p ".:~+:$ANDROID" exboot.fs startup.fs -e ": android ;" -e "also c-lib s\" `pwd`/lib/$VERSION/libcc-named/\" >libcc-named-dir libcc-path clear-path libcc-named-dir libcc-path also-path :noname 2drop s\" $DESTDIR$libccdir\" ; is replace-rpath previous" $srcdir/$i -e bye
done

: start-file ( -- )
    setup-player  true init-enqueue  ppause pvol# pvol ;

also opengl

0 Value oes-program

: omx-init create-oes-program to oes-program ;

also android

\ vertices


0.005e Fconstant m-lr
................................................................................
    >v
    rx m-lr f2* f- -0.96e >xy n> r% m-lr f- 0.98e >st c 0e -c 1e f>c v+
    rx             -0.9e  >xy n> r%         0.95e >st -c c 0e 1e f>c v+
    rx m-lr f2* f+ -0.96e >xy n> r% m-lr f+ 0.98e >st 0e -c c 1e f>c v+
    v> 4 i, 5 i, 6 i, ;

: rectangle ( -- )
    >v
    -1e  1e >xy n> 0e 0e >st  $000000FF rgba>c v+
     1e  1e >xy n> 1e 0e >st  $000000FF rgba>c v+
     1e -1e >xy n> 1e 1e >st  $000000FF rgba>c v+
    -1e -1e >xy n> 0e 1e >st  $000000FF rgba>c v+
    v> 0 i, 1 i, 2 i, 0 i, 2 i, 3 i, ;

\ player
................................................................................
	    utime lastseek 2@ delta-seek d+ du> IF
		5 3 click-regions
		2dup 2 1 d= IF  pplay? IF
			ppause
			get-deltat mkv-time-off f! 0e first-timestamp f!
		    ELSE pplay THEN  THEN
		dup 2 = IF
		    r@ x0 @ s>f w @ fm/ 1.1e f* 0.05e f- 0e fmax 1e fmin
		    pplay? IF  ppause  THEN
		    queue-flush  >pos  true init-enqueue pplay
		THEN
		2drop
		utime lastseek 2!
	    THEN
	THEN  r@ action off
................................................................................
    BEGIN
	draw-frame check-input
	cues>mts-run? 0= pplay? and  IF  ppause  THEN
    level# @ 0= UNTIL
    ppause screen-keep ;
: play-ts ( addr u -- ) ['] read-ts-file is read-ts
    open-mts start-file play-loop ;

: play-mkv ( addr u -- ) ['] pull-queue is read-ts
    'm' emit screen-sync
    <event e$, ->open-mkv 0 elit, ->cues cue-task event>
    'k' emit screen-sync
    start-file
    'v' emit screen-sync
    play-loop stop-player ;
: replay% ( r -- )  >pos  true init-enqueue play-loop ;
................................................................................
    cue-task IF
	<event 0 elit, ->cues cue-task event>
    ELSE
	0. ts-fd reposition-file throw
    THEN
    true init-enqueue play-loop stop-player ;

: gs "/storage/extSdCard/Filme/gangnamstyle.ts" play-ts ;
: jb "/storage/extSdCard/Filme/jb.mkv" play-mkv ;

cue-converter \ start task a bit ahead of game

previous previous previous

: start-file ( -- )
    setup-player  true init-enqueue  ppause pvol# pvol ;

also opengl

0 Value oes-program

: omx-init ( -- ) create-oes-program to oes-program ;

also android

\ vertices


0.005e Fconstant m-lr
................................................................................
    >v
    rx m-lr f2* f- -0.96e >xy n> r% m-lr f- 0.98e >st c 0e -c 1e f>c v+
    rx             -0.9e  >xy n> r%         0.95e >st -c c 0e 1e f>c v+
    rx m-lr f2* f+ -0.96e >xy n> r% m-lr f+ 0.98e >st 0e -c c 1e f>c v+
    v> 4 i, 5 i, 6 i, ;

: rectangle ( -- )
    i>off >v
    -1e  1e >xy n> 0e 0e >st  $000000FF rgba>c v+
     1e  1e >xy n> 1e 0e >st  $000000FF rgba>c v+
     1e -1e >xy n> 1e 1e >st  $000000FF rgba>c v+
    -1e -1e >xy n> 0e 1e >st  $000000FF rgba>c v+
    v> 0 i, 1 i, 2 i, 0 i, 2 i, 3 i, ;

\ player
................................................................................
	    utime lastseek 2@ delta-seek d+ du> IF
		5 3 click-regions
		2dup 2 1 d= IF  pplay? IF
			ppause
			get-deltat mkv-time-off f! 0e first-timestamp f!
		    ELSE pplay THEN  THEN
		dup 2 = IF
		    r@ x0 @ s>f dpy-w @ fm/ 1.1e f* 0.05e f- 0e fmax 1e fmin
		    pplay? IF  ppause  THEN
		    queue-flush  >pos  true init-enqueue pplay
		THEN
		2drop
		utime lastseek 2!
	    THEN
	THEN  r@ action off
................................................................................
    BEGIN
	draw-frame check-input
	cues>mts-run? 0= pplay? and  IF  ppause  THEN
    level# @ 0= UNTIL
    ppause screen-keep ;
: play-ts ( addr u -- ) ['] read-ts-file is read-ts
    open-mts start-file play-loop ;
: play-mkv ( addr u -- )
    ['] pull-queue is read-ts
    'm' emit screen-sync
    <event e$, ->open-mkv 0 elit, ->cues cue-task event>
    'k' emit screen-sync
    start-file
    'v' emit screen-sync
    play-loop stop-player ;
: replay% ( r -- )  >pos  true init-enqueue play-loop ;
................................................................................
    cue-task IF
	<event 0 elit, ->cues cue-task event>
    ELSE
	0. ts-fd reposition-file throw
    THEN
    true init-enqueue play-loop stop-player ;

: gs "/storage/extSdCard/Filme/gangnamstyle.mkv" play-mkv ;
: jb "/storage/extSdCard/Filme/jb.mkv" play-mkv ;

cue-converter \ start task a bit ahead of game

previous previous previous

## ExampleLib Example: an example of using Automake to link with a library

AC_INIT([freetype-gl], [1.0], [bernd@net2o.de], [freetype-gl for Linux/Android],
        [http://lonesock.net/soil.html])
AC_PREREQ([2.59])
AM_INIT_AUTOMAKE([1.10 -Wall no-define])
AC_CONFIG_MACRO_DIR([m4])
AC_CONFIG_HEADERS([config.h])
AC_PROG_CC
AM_PROG_AR
LT_INIT

case $CC in
     *android*)
	LIBADD="-llog -lglib-android-1.0"
	LIBGL=GLESv2
	;;
     *)
	LIBGL=GL
	;;
esac
AC_SUBST(LIBADD)
AC_SUBST(LIBGL)
LIBTOOL=${CC%gcc}libtool
AC_SUBST(LIBTOOL)

AC_CONFIG_FILES([Makefile])
AC_OUTPUT

## ExampleLib Example: an example of using Automake to link with a library

AC_INIT([SOIL], [1.0], [bernd@net2o.de], [soil for Linux],
        [http://lonesock.net/soil.html])
AC_PREREQ([2.59])
AM_INIT_AUTOMAKE([1.10 -Wall no-define])
AC_CONFIG_MACRO_DIR([m4])
AC_CONFIG_HEADERS([config.h])
AC_PROG_CC
AM_PROG_AR
LT_INIT

LIBTOOL=${CC%gcc}libtool
AC_SUBST(LIBTOOL)
AC_CONFIG_FILES([Makefile])
AC_OUTPUT

    f1 >o draw o> f7 >o draw o> f2 >o draw o> f3 >o draw o>
    f8 >o draw o> f4 >o draw o> f5 >o draw o> f6 >o draw o> ;

: widgets-test
    <draw0 draw0>
    <draw1 widgets-draw draw1>
    <draw2 widgets-draw draw2>

    sync ;

also [IFDEF] android android [THEN]

: widgets-demo ( -- ) program init [IFDEF] hidekb  hidekb [THEN]
    1 level# +!  BEGIN  widgets-test >looper  level# @ 0= UNTIL ;

previous

    f1 >o draw o> f7 >o draw o> f2 >o draw o> f3 >o draw o>
    f8 >o draw o> f4 >o draw o> f5 >o draw o> f6 >o draw o> ;

: widgets-test
    <draw0 draw0>
    <draw1 widgets-draw draw1>
    <draw2 widgets-draw draw2>
    <draw3 widgets-draw draw3>
    sync ;

also [IFDEF] android android [THEN]

: widgets-demo ( -- )  [IFDEF] hidekb  hidekb [THEN]
    1 level# +!  BEGIN  widgets-test >looper  level# @ 0= UNTIL ;

previous

    field: parent-w
    field: x
    field: y
    field: w
    field: h \ above baseline
    field: d \ below baseline
    method draw ( -- )
    method hglue

    method vglue
    method hglue@ \ cached variant
    method vglue@ \ cached variant

    method xywh
    method xywhd
    method !size \ set your own size
end-class widget

:noname x @ y @ h @ - w @ h @ d @ + ; widget to xywh
:noname x @ y @ w @ h @ d @ ; widget to xywhd
' noop widget to !size







widget class
    field: child-w
    field: act
    method resized
    method map
end-class box
................................................................................

widget class
    field: text-string
    field: text-font
    field: text-color
end-class text



: text-draw ( -- ) layer 2 <> ?EXIT




    x @ s>f penxy sf!  y @ s>f penxy sfloat+ sf!
    text-font @ to font  text-color @ color !
    text-string $@ render-string ;
: text-!size ( -- )
    text-string $@ layout-string
    f>s d ! f>s h ! f>s w ! ;
' text-draw text to draw
' text-!size text to !size

\ draw wrapper
................................................................................
: draw0> ( -- ) clear v0 i0 ;

: <draw1 ( -- )  1 to layer
    z-bias set-color+
    program glUseProgram  style-tex ;
: draw1> ( -- )  GL_TRIANGLES draw-elements v0 i0 ;

: <draw2 ( -- )  2 to layer


    1-bias set-color+
    program glUseProgram  atlas-tex ;
: draw2> ( -- )  GL_TRIANGLES draw-elements v0 i0 ;

Variable style-i#

: load-style ( addr u -- n )  style-tex
    style-i# @ 8 /mod 128 * >r 128 * r> 2swap load-subtex 2drop
    style-i# @ 1 style-i# +! ;
: style: load-style Create , DOES> @ frame# ! ;

"button.png" style: button1
"button2.png" style: button2
"button3.png" style: button3

previous previous previous set-current

    field: parent-w
    field: x
    field: y
    field: w
    field: h \ above baseline
    field: d \ below baseline
    method draw ( -- )
    method hglue ( -- typ sub add )
    method dglue ( -- typ sub add )
    method vglue ( -- typ sub add )
    method hglue@ ( -- typ sub add ) \ cached variant
    method dglue@ ( -- typ sub add ) \ cached variant
    method vglue@ ( -- typ sub add ) \ cached variant
    method xywh ( -- x0 y0 w h )
    method xywhd ( -- x y w h d )
    method !size \ set your own size
end-class widget

:noname x @ y @ h @ - w @ h @ d @ + ; widget to xywh
:noname x @ y @ w @ h @ d @ ; widget to xywhd
' noop widget to !size
:noname w @ 0 0 ; widget to hglue
:noname h @ 0 0 ; widget to vglue
:noname d @ 0 0 ; widget to dglue
' hglue widget to hglue@
' vglue widget to vglue@
' dglue widget to dglue@

widget class
    field: child-w
    field: act
    method resized
    method map
end-class box
................................................................................

widget class
    field: text-string
    field: text-font
    field: text-color
end-class text

Variable glyphs$

: text-draw ( -- )
    layer 2 = IF
	text-font @ to font text-string $@ glyphs$ $+!
	EXIT  THEN
    layer 3 = IF
	x @ s>f penxy sf!  y @ s>f penxy sfloat+ sf!
	text-font @ to font  text-color @ color !
	text-string $@ render-string THEN ;
: text-!size ( -- )
    text-string $@ layout-string
    f>s d ! f>s h ! f>s w ! ;
' text-draw text to draw
' text-!size text to !size

\ draw wrapper
................................................................................
: draw0> ( -- ) clear v0 i0 ;

: <draw1 ( -- )  1 to layer
    z-bias set-color+
    program glUseProgram  style-tex ;
: draw1> ( -- )  GL_TRIANGLES draw-elements v0 i0 ;

: <draw2 ( -- )  2 to layer s" " glyphs$ $! ;
: draw2> ( -- )  glyphs$ $@ load-glyph$ ;
: <draw3 ( -- )  3 to layer
    1-bias set-color+
    program glUseProgram  atlas-tex ;
: draw3> ( -- )  GL_TRIANGLES draw-elements v0 i0 ;

Variable style-i#

: load-style ( addr u -- n )  style-tex
    style-i# @ 8 /mod 128 * >r 128 * r> 2swap load-subtex 2drop
    style-i# @ 1 style-i# +! ;
: style: load-style Create , DOES> @ frame# ! ;

"button.png" style: button1
"button2.png" style: button2
"button3.png" style: button3

previous previous previous set-current

\ location services

also jni

jni-class: android/location/Location

jni-method: getAccuracy getAccuracy ()F
jni-method: getAltitude getAltitude ()D
jni-method: getBearing getBearing ()F
jni-method: getAltitude getAltitude ()D
jni-method: getLatitude getLatitude ()D
jni-method: getLongitude getLongitude ()D
jni-method: getProvider getProvider ()Ljava/lang/String;
jni-method: getSpeed getSpeed ()F
jni-method: getTime getTime ()J

jni-class: android/location/LocationManager

jni-method: getAllProviders getAllProviders ()Ljava/util/List;
jni-method: getProviders getProviders (Z)Ljava/util/List;
jni-method: getProvider getProvider (Ljava/lang/String;)Landroid/location/LocationProvider;
jni-method: requestLocationUpdates requestLocationUpdates (Ljava/lang/String;JFLandroid/location/LocationListener;)V
jni-method: getLastKnownLocation getLastKnownLocation (Ljava/lang/String;)Landroid/location/Location;
jni-method: removeUpdates removeUpdates (Landroid/location/LocationListener;)V


previous

: start-file ( -- )
    setup-player  true init-enqueue  ppause pvol# pvol ;

also opengl

0 Value oes-program

: omx-init create-oes-program to oes-program ;

also android

\ vertices


0.005e Fconstant m-lr
................................................................................
    >v
    rx m-lr f2* f- -0.96e >xy n> r% m-lr f- 0.98e >st c 0e -c 1e f>c v+
    rx             -0.9e  >xy n> r%         0.95e >st -c c 0e 1e f>c v+
    rx m-lr f2* f+ -0.96e >xy n> r% m-lr f+ 0.98e >st 0e -c c 1e f>c v+
    v> 4 i, 5 i, 6 i, ;

: rectangle ( -- )
    >v
    -1e  1e >xy n> 0e 0e >st  $000000FF rgba>c v+
     1e  1e >xy n> 1e 0e >st  $000000FF rgba>c v+
     1e -1e >xy n> 1e 1e >st  $000000FF rgba>c v+
    -1e -1e >xy n> 0e 1e >st  $000000FF rgba>c v+
    v> 0 i, 1 i, 2 i, 0 i, 2 i, 3 i, ;

\ player
................................................................................
	    utime lastseek 2@ delta-seek d+ du> IF
		5 3 click-regions
		2dup 2 1 d= IF  pplay? IF
			ppause
			get-deltat mkv-time-off f! 0e first-timestamp f!
		    ELSE pplay THEN  THEN
		dup 2 = IF
		    r@ x0 @ s>f w @ fm/ 1.1e f* 0.05e f- 0e fmax 1e fmin
		    pplay? IF  ppause  THEN
		    queue-flush  >pos  true init-enqueue pplay
		THEN
		2drop
		utime lastseek 2!
	    THEN
	THEN  r@ action off
................................................................................
    BEGIN
	draw-frame check-input
	cues>mts-run? 0= pplay? and  IF  ppause  THEN
    level# @ 0= UNTIL
    ppause screen-keep ;
: play-ts ( addr u -- ) ['] read-ts-file is read-ts
    open-mts start-file play-loop ;

: play-mkv ( addr u -- ) ['] pull-queue is read-ts
    'm' emit screen-sync
    <event e$, ->open-mkv 0 elit, ->cues cue-task event>
    'k' emit screen-sync
    start-file
    'v' emit screen-sync
    play-loop stop-player ;
: replay% ( r -- )  >pos  true init-enqueue play-loop ;
................................................................................
    cue-task IF
	<event 0 elit, ->cues cue-task event>
    ELSE
	0. ts-fd reposition-file throw
    THEN
    true init-enqueue play-loop stop-player ;

: gs "/storage/extSdCard/Filme/gangnamstyle.ts" play-ts ;
: jb "/storage/extSdCard/Filme/jb.mkv" play-mkv ;

cue-converter \ start task a bit ahead of game

previous previous previous

: start-file ( -- )
    setup-player  true init-enqueue  ppause pvol# pvol ;

also opengl

0 Value oes-program

: omx-init ( -- ) create-oes-program to oes-program ;

also android

\ vertices


0.005e Fconstant m-lr
................................................................................
    >v
    rx m-lr f2* f- -0.96e >xy n> r% m-lr f- 0.98e >st c 0e -c 1e f>c v+
    rx             -0.9e  >xy n> r%         0.95e >st -c c 0e 1e f>c v+
    rx m-lr f2* f+ -0.96e >xy n> r% m-lr f+ 0.98e >st 0e -c c 1e f>c v+
    v> 4 i, 5 i, 6 i, ;

: rectangle ( -- )
    i>off >v
    -1e  1e >xy n> 0e 0e >st  $000000FF rgba>c v+
     1e  1e >xy n> 1e 0e >st  $000000FF rgba>c v+
     1e -1e >xy n> 1e 1e >st  $000000FF rgba>c v+
    -1e -1e >xy n> 0e 1e >st  $000000FF rgba>c v+
    v> 0 i, 1 i, 2 i, 0 i, 2 i, 3 i, ;

\ player
................................................................................
	    utime lastseek 2@ delta-seek d+ du> IF
		5 3 click-regions
		2dup 2 1 d= IF  pplay? IF
			ppause
			get-deltat mkv-time-off f! 0e first-timestamp f!
		    ELSE pplay THEN  THEN
		dup 2 = IF
		    r@ x0 @ s>f dpy-w @ fm/ 1.1e f* 0.05e f- 0e fmax 1e fmin
		    pplay? IF  ppause  THEN
		    queue-flush  >pos  true init-enqueue pplay
		THEN
		2drop
		utime lastseek 2!
	    THEN
	THEN  r@ action off
................................................................................
    BEGIN
	draw-frame check-input
	cues>mts-run? 0= pplay? and  IF  ppause  THEN
    level# @ 0= UNTIL
    ppause screen-keep ;
: play-ts ( addr u -- ) ['] read-ts-file is read-ts
    open-mts start-file play-loop ;
: play-mkv ( addr u -- )
    ['] pull-queue is read-ts
    'm' emit screen-sync
    <event e$, ->open-mkv 0 elit, ->cues cue-task event>
    'k' emit screen-sync
    start-file
    'v' emit screen-sync
    play-loop stop-player ;
: replay% ( r -- )  >pos  true init-enqueue play-loop ;
................................................................................
    cue-task IF
	<event 0 elit, ->cues cue-task event>
    ELSE
	0. ts-fd reposition-file throw
    THEN
    true init-enqueue play-loop stop-player ;

: gs "/storage/extSdCard/Filme/gangnamstyle.mkv" play-mkv ;
: jb "/storage/extSdCard/Filme/jb.mkv" play-mkv ;

cue-converter \ start task a bit ahead of game

previous previous previous

\ Linux bindings for GLES

include x.fs

also x11

0 Value dpy
0 Value screen-struct
0 Value screen
0 Value win





Variable need-sync
Variable need-show
Variable kbflag


























: get-display ( -- w h )
    "DISPLAY" getenv drop XOpenDisplay to dpy
    dpy XDefaultScreenOfDisplay to screen-struct
    dpy XDefaultScreen to screen


    screen-struct screen-width l@
    screen-struct screen-height l@ ;

: simple-win ( events cstring w h -- )
    2>r dpy dup XDefaultRootWindow
    0 0 2r> 1 0 0 XCreateSimpleWindow  to win
    dpy win rot XStoreName drop

    dpy win rot XSelectInput drop
    dpy win XMapWindow drop
    dpy 0 XSync drop ;












0
KeyPressMask or
KeyReleaseMask or
ButtonPressMask or
ButtonReleaseMask or
EnterWindowMask or
LeaveWindowMask or
PointerMotionMask or
KeymapStateMask or
ExposureMask or
VisibilityChangeMask or
StructureNotifyMask or
ResizeRedirectMask or
SubstructureNotifyMask or
SubstructureRedirectMask or
FocusChangeMask or
PropertyChangeMask or
ColormapChangeMask or
OwnerGrabButtonMask or
Constant default-events

: ?looper ;
: >looper 10 ms ;

: linux ;

Defer window-init    ' noop is window-init
Defer config-changed ' noop is config-changed
Defer screen-ops     ' noop IS screen-ops

: term-cr defers cr ;
................................................................................
field: x9
field: y9
end-structure

app_input_state buffer: *input

Variable level#

\ Linux bindings for GLES

require x.fs

also x11

0 Value dpy
0 Value screen-struct
0 Value screen
0 Value win
0 Value ic
0 Value im
0 Value xim
0 Value fontset

Variable need-sync
Variable need-show
Variable kbflag

XIMPreeditPosition XIMPreeditArea or
XIMPreeditNothing or XIMPreeditNone or Constant XIMPreedit

: best-im ( -- im )
    XSupportsLocale IF
	"XMODIFIERS" getenv drop ?dup-IF
	    XSetLocaleModifiers  0= IF
		." Warning: Cannot set locale modifiers to '"
		"XMODIFIERS" getenv type  ." '" cr THEN  THEN
    THEN
    dpy 0 0 0 XOpenIM dup to xim
    IF  0 { w^ styles } xim "queryInputStyle\0" drop styles 0 XGetIMValues
	0<> ?EXIT \ didn't succeed
	0  styles @ cell+ @ styles @ w@ cells bounds ?DO
	    I @ dup XIMPreedit and 0<> swap XIMStatusNothing and 0<> and
	    IF  drop I @  LEAVE  THEN
	cell +LOOP  dup 0= IF ." No style found" cr  THEN
	styles @ XFree drop
    ELSE  0  THEN ;

: set-fontset ( -- )
    "-*-FreeSans-*-r-*-*-*-120-*-*-*-*-*-*,-misc-fixed-*-r-*-*-*-130-*-*-*-*-*-*\0" drop 0 0 0 { w^ misslist w^ miss# w^ defstring }
    dpy swap misslist miss# defstring XCreateFontSet to fontset
    misslist @ XFreeStringList ;

: get-display ( -- w h )
    "DISPLAY" getenv drop XOpenDisplay to dpy
    dpy XDefaultScreenOfDisplay to screen-struct
    dpy XDefaultScreen to screen
    best-im to im  set-fontset
    dpy #38 0 XKeycodeToKeysym drop
    screen-struct screen-width l@
    screen-struct screen-height l@ ;



4 buffer: spot \ spot location, two shorts


: get-ic ( win -- ) xim 0= IF  drop  EXIT  THEN
    ic IF  >r ic "focusWindow\0" drop r> 0 XSetICValues drop
	EXIT  THEN
    0 "fontSet\0" drop fontset "spotLocation\0" drop spot 0
    XVaCreateNestedList_2 { win list }
    xim "inputStyle\0" drop im "preeditAttributes\0" drop list
    "focusWindow\0" drop win 0 XCreateIC_3 dup to ic
    list XFree drop
    ?dup-IF  XSetICFocus  THEN ;

: focus-ic ( win -- )  ic IF
	>r ic "focusWindow\0" drop r@ "clientWindow\0" drop r> 0
	XSetICValues_2 drop  ic XSetICFocus
    THEN ;

0
KeyPressMask or
KeyReleaseMask or
ButtonPressMask or
ButtonReleaseMask or
EnterWindowMask or
LeaveWindowMask or
PointerMotionMask or
\ KeymapStateMask or
ExposureMask or
\ VisibilityChangeMask or
StructureNotifyMask or
\ ResizeRedirectMask or
SubstructureNotifyMask or
SubstructureRedirectMask or
FocusChangeMask or
PropertyChangeMask or
\ ColormapChangeMask or
\ OwnerGrabButtonMask or
Constant default-events




: linux ;

Defer window-init    ' noop is window-init
Defer config-changed ' noop is config-changed
Defer screen-ops     ' noop IS screen-ops

: term-cr defers cr ;
................................................................................
field: x9
field: y9
end-structure

app_input_state buffer: *input

Variable level#

\ handle X11 events

object class
    cell 4 = [IF]
	drop 0 4 +field e.type
	drop 4 4 +field e.serial
	drop 8 4 +field e.send_event
	drop 12 4 +field e.display
	drop 16 4 +field e.window
	drop 20 4 +field e.r-width
	drop 24 4 +field e.r-height
	drop 28 4 +field e.time
	drop 32 4 +field e.c-width
	drop 36 4 +field e.c-height
	drop 32 4 +field e.x
	drop 36 4 +field e.y
	drop 48 4 +field e.state
	drop 52 4 +field e.code \ key and button
    [ELSE]
	drop 0 4 +field e.type
	drop 8 8 +field e.serial
	drop 16 4 +field e.send_event
	drop 24 8 +field e.display
	drop 32 8 +field e.window
	drop 40 4 +field e.r-width  \ resize
	drop 44 4 +field e.r-height \ resize
	drop 56 8 +field e.time
	drop 56 4 +field e.c-width \ configure
	drop 60 4 +field e.c-height
	drop 64 4 +field e.x
	drop 68 4 +field e.y
	drop 80 4 +field e.state
	drop 84 4 +field e.code \ key and button
    [THEN]
    drop 0 union-_XEvent +field event
    $100 +field look_chars
    4 +field look_key
    4 +field comp_stat
    method DoNull \ doesn't exist
    method DoOne  \ doesn't exit, either
    method DoKeyPress
    method DoKeyRelease
    method DoButtonPress
    method DoButtonRelease
    method DoMotionNotify
    method DoEnterNotify
    method DoLeaveNotify
    method DoFocusIn
    method DoFocusOut
    method DoKeymapNotify
    method DoExpose
    method DoGraphicsExpose
    method DoNoExpose
    method DoVisibilityNotify
    method DoCreateNotify
    method DoDestroyNotify
    method DoUnmapNotify
    method DoMapNotify
    method DoMapRequest
    method DoReparentNotify
    method DoConfigureNotify
    method DoConfigureRequest
    method DoGravityNotify
    method DoResizeRequest
    method DoCirculateNotify
    method DoCirculateRequest
    method DoPropertyNotify
    method DoSelectionClear
    method DoSelectionRequest
    method DoSelectionNotify
    method DoColormapNotify
    method DoClientMessage
    method DoMappingNotify
    method DoGenericEvent
end-class handler-class

User event-handler  handler-class new event-handler !

Variable exposed

: $, ( addr u -- )  here over 1+ allot place ;

Create x-key>ekey \ very minimal set for a start
$FF08 , "\b" $,
$FF09 , "\t" $,
$FF0D , "\r" $,
$FF50 , "\e[H" $,
$FF51 , "\e[D" $,
$FF52 , "\e[A" $,
$FF53 , "\e[C" $,
$FF54 , "\e[B" $,
$FF55 , "\e[5~" $,
$FF56 , "\e[6~" $,
$FFFF , "\b" $, \ is not delete, is backspace!
0 , 0 c,
DOES> ( x-key -- addr u )
  swap >r
  BEGIN  dup cell+ swap @ dup r@ <> and WHILE  count +  REPEAT
  count rdrop ;

: getwh ( -- )
	0 0 dpy-w @ dpy-h @ glViewport ;

:noname ; handler-class to DoNull \ doesn't exist
:noname ; handler-class to DoOne  \ doesn't exit, either
:noname  ic event look_chars $FF look_key comp_stat  XUtf8LookupString
    ?dup-IF  look_chars swap
    ELSE   look_key l@ x-key>ekey  THEN  unkeys
; handler-class to DoKeyPress
:noname ; handler-class to DoKeyRelease
:noname  0 *input action ! 1 *input pressure !
    e.x l@ e.y l@ *input y0 ! *input x0 ! ; handler-class to DoButtonPress
:noname  1 *input action ! 0 *input pressure !
    e.x l@ *input x0 !
    e.y l@ *input y0 ! ; handler-class to DoButtonRelease
:noname
    *input pressure @ IF
	2 *input action !
	e.x l@ e.y l@ *input y0 ! *input x0 !
    THEN ; handler-class to DoMotionNotify
:noname ; handler-class to DoEnterNotify
:noname ; handler-class to DoLeaveNotify
:noname e.window @ focus-ic ; handler-class to DoFocusIn
:noname ; handler-class to DoFocusOut
:noname ; handler-class to DoKeymapNotify
:noname exposed on ; handler-class to DoExpose
:noname exposed on ; handler-class to DoGraphicsExpose
:noname ; handler-class to DoNoExpose
:noname ; handler-class to DoVisibilityNotify
:noname ; handler-class to DoCreateNotify
:noname ; handler-class to DoDestroyNotify
:noname ; handler-class to DoUnmapNotify
:noname ; handler-class to DoMapNotify
:noname ; handler-class to DoMapRequest
:noname ; handler-class to DoReparentNotify
:noname  e.c-width l@ dpy-w ! e.c-height l@ dpy-h !
    ctx IF  config-changed  ELSE  getwh  THEN ; handler-class to DoConfigureNotify
:noname ; handler-class to DoConfigureRequest
:noname ; handler-class to DoGravityNotify
:noname  e.r-width l@ dpy-w ! e.r-height l@ dpy-h ! config-changed ; handler-class to DoResizeRequest
:noname ; handler-class to DoCirculateNotify
:noname ; handler-class to DoCirculateRequest
:noname ; handler-class to DoPropertyNotify
:noname ; handler-class to DoSelectionClear
:noname ; handler-class to DoSelectionRequest
:noname ; handler-class to DoSelectionNotify
:noname ; handler-class to DoColormapNotify
:noname ; handler-class to DoClientMessage
:noname ; handler-class to DoMappingNotify
:noname ; handler-class to DoGenericEvent

: handle-event ( -- ) e.type l@ cells o#+ [ -1 cells , ] @ + perform ;
: get-events ( -- )  event-handler @ >o
    BEGIN  dpy XPending  WHILE  dpy event XNextEvent drop
	    event 0 XFilterEvent 0= IF  handle-event  THEN
    REPEAT o> ;

\ polling of FDs

require unix/socket.fs

User xptimeout  cell uallot drop
#10000000 Value xpoll-timeout# \ 10ms, don't sleep too long
xpoll-timeout# 0 xptimeout 2!
2 Value xpollfd#
User xpollfds
xpollfds pollfd %size xpollfd# * dup cell- uallot drop erase

: xfds!+ ( fileno flag addr -- addr' )
    >r r@ events w!  r@ fd l!  r> pollfd %size + ; 

: >poll-events ( -- n )
    stdin fileno POLLIN  xpollfds xfds!+ >r
    dpy IF  dpy XConnectionNumber POLLIN  r> xfds!+  ELSE  r>  THEN
    xpollfds - pollfd %size / ;

: #looper ( delay -- )
    >poll-events >r
    0 xptimeout 2!
    xpollfds r>
    [IFDEF] ppoll
	xptimeout 0 ppoll 0>
    [ELSE]
	xptimeout cell+ @ #1000000 / poll 0>
    [THEN]
    IF
	xpollfds pollfd %size + revents w@ POLLIN = IF  get-events  THEN
    THEN ;

: >looper ( -- )  xpoll-timeout# #looper ;
: >exposed  ( -- )  exposed off  BEGIN  >looper exposed @  UNTIL ;
: ?looper ( -- )  ;

: simple-win ( events cstring w h -- )
    2>r dpy dup XDefaultRootWindow
    0 0 2r> 1 0 0 XCreateSimpleWindow  to win
    dpy win rot XStoreName drop
    dpy win rot XSelectInput drop
    dpy win XMapWindow drop
    win get-ic
    dpy 0 XSync drop >exposed ;

: x-key ( -- key )
    need-show on  key? IF  defers key  EXIT  THEN
    BEGIN  xpoll-timeout# #looper  key? screen-ops UNTIL  defers key ;

' x-key IS key

\ wrapper to load Swig-generated libraries

Vocabulary opengl
also opengl definitions

c-library opengl
    \c #include <GL/gl.h>
    \c #define GL_GLEXT_PROTOTYPES
    \c #include <GL/glx.h>

    s" GL" add-lib
................................................................................
    \ c-function android_createDisplaySurface android_createDisplaySurface -- a ( -- window )
   
    include gl.fs
    include glx.fs

end-c-library

previous definitions

\ wrapper to load Swig-generated libraries

Vocabulary opengl
get-current also opengl definitions

c-library opengl
    \c #include <GL/gl.h>
    \c #define GL_GLEXT_PROTOTYPES
    \c #include <GL/glx.h>

    s" GL" add-lib
................................................................................
    \ c-function android_createDisplaySurface android_createDisplaySurface -- a ( -- window )
   
    include gl.fs
    include glx.fs

end-c-library

previous set-current

\ include xlib stuff

Vocabulary X11
also X11 definitions

c-library xlib
    \c #include <X11/X.h>
    \c #include <X11/Xlib.h>
    \c #include <X11/Xutil.h>

    s" X11" add-lib

    include xlib.fs

end-c-library

previous definitions

\ include xlib stuff

Vocabulary X11
get-current also X11 definitions

c-library xlib
    \c #include <X11/X.h>
    \c #include <X11/Xlib.h>
    \c #include <X11/Xutil.h>

    s" X11" add-lib

    include xlib.fs

end-c-library

previous set-current

256	constant XIMStatusArea
512	constant XIMStatusCallbacks
1024	constant XIMStatusNothing
2048	constant XIMStatusNone
-1	constant XBufferOverflow
1	constant XLookupNone
2	constant XLookupChars
3	constant XLookupKeySym
4	constant XLookupBoth
1	constant XIMReverse
2	constant XIMUnderline
4	constant XIMHighlight
32	constant XIMPrimary
64	constant XIMSecondary
128	constant XIMTertiary
................................................................................
c-function XwcDrawString XwcDrawString a n a a n n a n -- void
c-function Xutf8DrawString Xutf8DrawString a n a a n n a n -- void
c-function XmbDrawImageString XmbDrawImageString a n a a n n a n -- void
c-function XwcDrawImageString XwcDrawImageString a n a a n n a n -- void
c-function Xutf8DrawImageString Xutf8DrawImageString a n a a n n a n -- void
c-function XOpenIM XOpenIM a a a a -- a
c-function XCloseIM XCloseIM a -- n
c-function XGetIMValues XGetIMValues a  -- a
c-function XSetIMValues XSetIMValues a  -- a
c-function XDisplayOfIM XDisplayOfIM a -- a
c-function XLocaleOfIM XLocaleOfIM a -- a
c-function XCreateIC XCreateIC a  -- a


c-function XDestroyIC XDestroyIC a -- void
c-function XSetICFocus XSetICFocus a -- void
c-function XUnsetICFocus XUnsetICFocus a -- void
c-function XwcResetIC XwcResetIC a -- a
c-function XmbResetIC XmbResetIC a -- a
c-function Xutf8ResetIC Xutf8ResetIC a -- a
c-function XSetICValues XSetICValues a  -- a

c-function XGetICValues XGetICValues a  -- a
c-function XIMOfIC XIMOfIC a -- a
c-function XFilterEvent XFilterEvent a n -- n
c-function XmbLookupString XmbLookupString a a a n a a -- n
c-function XwcLookupString XwcLookupString a a a n a a -- n
c-function Xutf8LookupString Xutf8LookupString a a a n a a -- n
c-function XVaCreateNestedList XVaCreateNestedList n  -- a

c-function XRegisterIMInstantiateCallback XRegisterIMInstantiateCallback a a a a a a -- n
c-function XUnregisterIMInstantiateCallback XUnregisterIMInstantiateCallback a a a a a a -- n
c-function XInternalConnectionNumbers XInternalConnectionNumbers a a a -- n
c-function XProcessInternalConnection XProcessInternalConnection a n -- void
c-function XAddConnectionWatch XAddConnectionWatch a a a -- n
c-function XRemoveConnectionWatch XRemoveConnectionWatch a a a -- void
c-function XSetAuthorization XSetAuthorization a n a n -- void

256	constant XIMStatusArea
512	constant XIMStatusCallbacks
1024	constant XIMStatusNothing
2048	constant XIMStatusNone
-1	constant XBufferOverflow
1	constant XLookupNone
2	constant XLookupChars
3	constant XLookupKeySym#
4	constant XLookupBoth
1	constant XIMReverse
2	constant XIMUnderline
4	constant XIMHighlight
32	constant XIMPrimary
64	constant XIMSecondary
128	constant XIMTertiary
................................................................................
c-function XwcDrawString XwcDrawString a n a a n n a n -- void
c-function Xutf8DrawString Xutf8DrawString a n a a n n a n -- void
c-function XmbDrawImageString XmbDrawImageString a n a a n n a n -- void
c-function XwcDrawImageString XwcDrawImageString a n a a n n a n -- void
c-function Xutf8DrawImageString Xutf8DrawImageString a n a a n n a n -- void
c-function XOpenIM XOpenIM a a a a -- a
c-function XCloseIM XCloseIM a -- n
c-function XGetIMValues XGetIMValues a a a a -- a
c-function XSetIMValues XSetIMValues a a a a -- a
c-function XDisplayOfIM XDisplayOfIM a -- a
c-function XLocaleOfIM XLocaleOfIM a -- a
c-function XCreateIC XCreateIC a a a a -- a
c-function XCreateIC_2 XCreateIC a a a a a a -- a
c-function XCreateIC_3 XCreateIC a a a a a a a a -- a
c-function XDestroyIC XDestroyIC a -- void
c-function XSetICFocus XSetICFocus a -- void
c-function XUnsetICFocus XUnsetICFocus a -- void
c-function XwcResetIC XwcResetIC a -- a
c-function XmbResetIC XmbResetIC a -- a
c-function Xutf8ResetIC Xutf8ResetIC a -- a
c-function XSetICValues XSetICValues a a a a -- a
c-function XSetICValues_2 XSetICValues a a a a a a -- a
c-function XGetICValues XGetICValues a a a a -- a
c-function XIMOfIC XIMOfIC a -- a
c-function XFilterEvent XFilterEvent a n -- n
c-function XmbLookupString XmbLookupString a a a n a a -- n
c-function XwcLookupString XwcLookupString a a a n a a -- n
c-function Xutf8LookupString Xutf8LookupString a a a n a a -- n
c-function XVaCreateNestedList XVaCreateNestedList n a a a -- a
c-function XVaCreateNestedList_2 XVaCreateNestedList n a a a a a -- a
c-function XRegisterIMInstantiateCallback XRegisterIMInstantiateCallback a a a a a a -- n
c-function XUnregisterIMInstantiateCallback XUnregisterIMInstantiateCallback a a a a a a -- n
c-function XInternalConnectionNumbers XInternalConnectionNumbers a a a -- n
c-function XProcessInternalConnection XProcessInternalConnection a n -- void
c-function XAddConnectionWatch XAddConnectionWatch a a a -- n
c-function XRemoveConnectionWatch XRemoveConnectionWatch a a a -- void
c-function XSetAuthorization XSetAuthorization a n a n -- void

256	constant XIMStatusArea
512	constant XIMStatusCallbacks
1024	constant XIMStatusNothing
2048	constant XIMStatusNone
-1	constant XBufferOverflow
1	constant XLookupNone
2	constant XLookupChars
3	constant XLookupKeySym
4	constant XLookupBoth
1	constant XIMReverse
2	constant XIMUnderline
4	constant XIMHighlight
32	constant XIMPrimary
64	constant XIMSecondary
128	constant XIMTertiary
................................................................................
c-function XwcDrawString XwcDrawString a n a a n n a n -- void
c-function Xutf8DrawString Xutf8DrawString a n a a n n a n -- void
c-function XmbDrawImageString XmbDrawImageString a n a a n n a n -- void
c-function XwcDrawImageString XwcDrawImageString a n a a n n a n -- void
c-function Xutf8DrawImageString Xutf8DrawImageString a n a a n n a n -- void
c-function XOpenIM XOpenIM a a a a -- a
c-function XCloseIM XCloseIM a -- n
c-function XGetIMValues XGetIMValues a  -- a
c-function XSetIMValues XSetIMValues a  -- a
c-function XDisplayOfIM XDisplayOfIM a -- a
c-function XLocaleOfIM XLocaleOfIM a -- a
c-function XCreateIC XCreateIC a  -- a


c-function XDestroyIC XDestroyIC a -- void
c-function XSetICFocus XSetICFocus a -- void
c-function XUnsetICFocus XUnsetICFocus a -- void
c-function XwcResetIC XwcResetIC a -- a
c-function XmbResetIC XmbResetIC a -- a
c-function Xutf8ResetIC Xutf8ResetIC a -- a
c-function XSetICValues XSetICValues a  -- a

c-function XGetICValues XGetICValues a  -- a
c-function XIMOfIC XIMOfIC a -- a
c-function XFilterEvent XFilterEvent a n -- n
c-function XmbLookupString XmbLookupString a a a n a a -- n
c-function XwcLookupString XwcLookupString a a a n a a -- n
c-function Xutf8LookupString Xutf8LookupString a a a n a a -- n
c-function XVaCreateNestedList XVaCreateNestedList n  -- a

c-function XRegisterIMInstantiateCallback XRegisterIMInstantiateCallback a a a a a a -- n
c-function XUnregisterIMInstantiateCallback XUnregisterIMInstantiateCallback a a a a a a -- n
c-function XInternalConnectionNumbers XInternalConnectionNumbers a a a -- n
c-function XProcessInternalConnection XProcessInternalConnection a n -- void
c-function XAddConnectionWatch XAddConnectionWatch a a a -- n
c-function XRemoveConnectionWatch XRemoveConnectionWatch a a a -- void
c-function XSetAuthorization XSetAuthorization a n a n -- void

256	constant XIMStatusArea
512	constant XIMStatusCallbacks
1024	constant XIMStatusNothing
2048	constant XIMStatusNone
-1	constant XBufferOverflow
1	constant XLookupNone
2	constant XLookupChars
3	constant XLookupKeySym#
4	constant XLookupBoth
1	constant XIMReverse
2	constant XIMUnderline
4	constant XIMHighlight
32	constant XIMPrimary
64	constant XIMSecondary
128	constant XIMTertiary
................................................................................
c-function XwcDrawString XwcDrawString a n a a n n a n -- void
c-function Xutf8DrawString Xutf8DrawString a n a a n n a n -- void
c-function XmbDrawImageString XmbDrawImageString a n a a n n a n -- void
c-function XwcDrawImageString XwcDrawImageString a n a a n n a n -- void
c-function Xutf8DrawImageString Xutf8DrawImageString a n a a n n a n -- void
c-function XOpenIM XOpenIM a a a a -- a
c-function XCloseIM XCloseIM a -- n
c-function XGetIMValues XGetIMValues a a a a -- a
c-function XSetIMValues XSetIMValues a a a a -- a
c-function XDisplayOfIM XDisplayOfIM a -- a
c-function XLocaleOfIM XLocaleOfIM a -- a
c-function XCreateIC XCreateIC a a a a -- a
c-function XCreateIC_2 XCreateIC a a a a a a -- a
c-function XCreateIC_3 XCreateIC a a a a a a a a -- a
c-function XDestroyIC XDestroyIC a -- void
c-function XSetICFocus XSetICFocus a -- void
c-function XUnsetICFocus XUnsetICFocus a -- void
c-function XwcResetIC XwcResetIC a -- a
c-function XmbResetIC XmbResetIC a -- a
c-function Xutf8ResetIC Xutf8ResetIC a -- a
c-function XSetICValues XSetICValues a a a a -- a
c-function XSetICValues_2 XSetICValues a a a a a a -- a
c-function XGetICValues XGetICValues a a a a -- a
c-function XIMOfIC XIMOfIC a -- a
c-function XFilterEvent XFilterEvent a n -- n
c-function XmbLookupString XmbLookupString a a a n a a -- n
c-function XwcLookupString XwcLookupString a a a n a a -- n
c-function Xutf8LookupString Xutf8LookupString a a a n a a -- n
c-function XVaCreateNestedList XVaCreateNestedList n a a a -- a
c-function XVaCreateNestedList_2 XVaCreateNestedList n a a a a a -- a
c-function XRegisterIMInstantiateCallback XRegisterIMInstantiateCallback a a a a a a -- n
c-function XUnregisterIMInstantiateCallback XUnregisterIMInstantiateCallback a a a a a a -- n
c-function XInternalConnectionNumbers XInternalConnectionNumbers a a a -- n
c-function XProcessInternalConnection XProcessInternalConnection a n -- void
c-function XAddConnectionWatch XAddConnectionWatch a a a -- n
c-function XRemoveConnectionWatch XRemoveConnectionWatch a a a -- void
c-function XSetAuthorization XSetAuthorization a n a n -- void

AM_INIT_AUTOMAKE([1.10 -Wall no-define])
AC_CONFIG_MACRO_DIR([m4])
AC_CONFIG_HEADERS([config.h])
AC_PROG_CC
AM_PROG_AR
LT_INIT



AC_CONFIG_FILES([Makefile])
AC_OUTPUT

AM_INIT_AUTOMAKE([1.10 -Wall no-define])
AC_CONFIG_MACRO_DIR([m4])
AC_CONFIG_HEADERS([config.h])
AC_PROG_CC
AM_PROG_AR
LT_INIT

LIBTOOL=${CC%gcc}libtool
AC_SUBST(LIBTOOL)
AC_CONFIG_FILES([Makefile])
AC_OUTPUT

    f1 >o draw o> f7 >o draw o> f2 >o draw o> f3 >o draw o>
    f8 >o draw o> f4 >o draw o> f5 >o draw o> f6 >o draw o> ;

: widgets-test
    <draw0 draw0>
    <draw1 widgets-draw draw1>
    <draw2 widgets-draw draw2>

    sync ;

also [IFDEF] android android [THEN]

: widgets-demo ( -- ) program init [IFDEF] hidekb  hidekb [THEN]
    1 level# +!  BEGIN  widgets-test >looper  level# @ 0= UNTIL ;

previous

    f1 >o draw o> f7 >o draw o> f2 >o draw o> f3 >o draw o>
    f8 >o draw o> f4 >o draw o> f5 >o draw o> f6 >o draw o> ;

: widgets-test
    <draw0 draw0>
    <draw1 widgets-draw draw1>
    <draw2 widgets-draw draw2>
    <draw3 widgets-draw draw3>
    sync ;

also [IFDEF] android android [THEN]

: widgets-demo ( -- )  [IFDEF] hidekb  hidekb [THEN]
    1 level# +!  BEGIN  widgets-test >looper  level# @ 0= UNTIL ;

previous

    field: parent-w
    field: x
    field: y
    field: w
    field: h \ above baseline
    field: d \ below baseline
    method draw ( -- )
    method hglue

    method vglue
    method hglue@ \ cached variant
    method vglue@ \ cached variant

    method xywh
    method xywhd
    method !size \ set your own size
end-class widget

:noname x @ y @ h @ - w @ h @ d @ + ; widget to xywh
:noname x @ y @ w @ h @ d @ ; widget to xywhd
' noop widget to !size







widget class
    field: child-w
    field: act
    method resized
    method map
end-class box
................................................................................

widget class
    field: text-string
    field: text-font
    field: text-color
end-class text



: text-draw ( -- ) layer 2 <> ?EXIT




    x @ s>f penxy sf!  y @ s>f penxy sfloat+ sf!
    text-font @ to font  text-color @ color !
    text-string $@ render-string ;
: text-!size ( -- )
    text-string $@ layout-string
    f>s d ! f>s h ! f>s w ! ;
' text-draw text to draw
' text-!size text to !size

\ draw wrapper
................................................................................
: draw0> ( -- ) clear v0 i0 ;

: <draw1 ( -- )  1 to layer
    z-bias set-color+
    program glUseProgram  style-tex ;
: draw1> ( -- )  GL_TRIANGLES draw-elements v0 i0 ;

: <draw2 ( -- )  2 to layer


    1-bias set-color+
    program glUseProgram  atlas-tex ;
: draw2> ( -- )  GL_TRIANGLES draw-elements v0 i0 ;

Variable style-i#

: load-style ( addr u -- n )  style-tex
    style-i# @ 8 /mod 128 * >r 128 * r> 2swap load-subtex 2drop
    style-i# @ 1 style-i# +! ;
: style: load-style Create , DOES> @ frame# ! ;

"button.png" style: button1
"button2.png" style: button2
"button3.png" style: button3

previous previous previous set-current

    field: parent-w
    field: x
    field: y
    field: w
    field: h \ above baseline
    field: d \ below baseline
    method draw ( -- )
    method hglue ( -- typ sub add )
    method dglue ( -- typ sub add )
    method vglue ( -- typ sub add )
    method hglue@ ( -- typ sub add ) \ cached variant
    method dglue@ ( -- typ sub add ) \ cached variant
    method vglue@ ( -- typ sub add ) \ cached variant
    method xywh ( -- x0 y0 w h )
    method xywhd ( -- x y w h d )
    method !size \ set your own size
end-class widget

:noname x @ y @ h @ - w @ h @ d @ + ; widget to xywh
:noname x @ y @ w @ h @ d @ ; widget to xywhd
' noop widget to !size
:noname w @ 0 0 ; widget to hglue
:noname h @ 0 0 ; widget to vglue
:noname d @ 0 0 ; widget to dglue
' hglue widget to hglue@
' vglue widget to vglue@
' dglue widget to dglue@

widget class
    field: child-w
    field: act
    method resized
    method map
end-class box
................................................................................

widget class
    field: text-string
    field: text-font
    field: text-color
end-class text

Variable glyphs$

: text-draw ( -- )
    layer 2 = IF
	text-font @ to font text-string $@ glyphs$ $+!
	EXIT  THEN
    layer 3 = IF
	x @ s>f penxy sf!  y @ s>f penxy sfloat+ sf!
	text-font @ to font  text-color @ color !
	text-string $@ render-string THEN ;
: text-!size ( -- )
    text-string $@ layout-string
    f>s d ! f>s h ! f>s w ! ;
' text-draw text to draw
' text-!size text to !size

\ draw wrapper
................................................................................
: draw0> ( -- ) clear v0 i0 ;

: <draw1 ( -- )  1 to layer
    z-bias set-color+
    program glUseProgram  style-tex ;
: draw1> ( -- )  GL_TRIANGLES draw-elements v0 i0 ;

: <draw2 ( -- )  2 to layer s" " glyphs$ $! ;
: draw2> ( -- )  glyphs$ $@ load-glyph$ ;
: <draw3 ( -- )  3 to layer
    1-bias set-color+
    program glUseProgram  atlas-tex ;
: draw3> ( -- )  GL_TRIANGLES draw-elements v0 i0 ;

Variable style-i#

: load-style ( addr u -- n )  style-tex
    style-i# @ 8 /mod 128 * >r 128 * r> 2swap load-subtex 2drop
    style-i# @ 1 style-i# +! ;
: style: load-style Create , DOES> @ frame# ! ;

"button.png" style: button1
"button2.png" style: button2
"button3.png" style: button3

previous previous previous set-current