Artifact f523328eb89b3c1e53a46f070e214b3fd4c486dd:
- File qrscan.fs — part of check-in [531f5bc61f] at 2019-01-16 17:45:30 on branch trunk — Replace 0 [IF] for emacs editings with \\\ (user: bernd size: 13021)
\ scan color QR codes on Android \ Copyright (C) 2016-2018 Bernd Paysan \ This program is free software: you can redistribute it and/or modify \ it under the terms of the GNU Affero General Public License as published by \ the Free Software Foundation, either version 3 of the License, or \ (at your option) any later version. \ This program is distributed in the hope that it will be useful, \ but WITHOUT ANY WARRANTY; without even the implied warranty of \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the \ GNU Affero General Public License for more details. \ You should have received a copy of the GNU Affero General Public License \ along with this program. If not, see <http://www.gnu.org/licenses/>. require minos2/gl-helper.fs [IFDEF] android require minos2/android-recorder.fs [ELSE] [IFUNDEF] cam-w $100 value cam-w $100 value cam-h [THEN] [THEN] \ replace some tools available under net2o [IFUNDEF] qr( debug: qr( +db qr( \ turn it on ) [THEN] [IFUNDEF] xtype : hex[ ]] [: [[ ; immediate : ]hex ]] ;] $10 base-execute [[ ; immediate : xtype ( addr u -- ) hex[ bounds ?DO I c@ 0 <# # # #> type LOOP ]hex ; [THEN] [IFUNDEF] taghash? : taghash? ( addrkey u1 addrecc u2 tag -- flag ) drop 2drop 2drop true ; [THEN] \ scan matrix manipulation Create scan-matrix 1e sf, 0e sf, 0e sf, 0e sf, 0e sf, 1e sf, 0e sf, 0e sf, 0e sf, 0e sf, 1e sf, 0e sf, 0e sf, 0e sf, 0e sf, 1e sf, scan-matrix 11 sfloats + Constant 3d-enabler 32 sfloats buffer: scan-inverse 32 sfloats buffer: inverse-default inverse-default 32 sfloats bounds [?DO] 1e fdup [I] sf! [I] 4 sfloats + sf! 9 sfloats [+LOOP] 83e FValue x-scansize 83e FValue y-scansize 0e FValue y-offset 0e FValue x-offset \ matrix inversion ' dfloats alias 8* : .mat { mat -- } 4 0 DO cr 8 0 DO mat J 8* I + sfloats + sf@ f. LOOP LOOP ; : init-scan' ( -- ) inverse-default scan-inverse [ 32 sfloats ]L move ; : sfax+y8 ( ra addr1 addr2 -- ) [ 8 sfloats ]L bounds ?DO dup sf@ fover I sf@ f* f+ dup sf! sfloat+ [ 1 sfloats ]L +LOOP drop fdrop ; : sfax8 ( ra addr -- ) [ 8 sfloats ]L bounds ?DO fdup I sf@ f* I sf! [ 1 sfloats ]L +LOOP fdrop ; : tij8 ( addr1 addr2 -- ) [ 8 sfloats ]L bounds ?DO dup sf@ I sf@ dup sf! I sf! sfloat+ [ 1 sfloats ]L +LOOP drop ; : matrix-invert4 { mat -- } \ shortcut to invert typical matrix mat sf@ fabs mat [ 8 sfloats ]L + sf@ fabs f< IF mat dup [ 8 sfloats ]L + tij8 \ exchange two lines THEN 4 0 DO 4 0 DO mat J [ 9 sfloats ]L * + sf@ 1/f I J <> IF mat I 8* sfloats + mat J 8* sfloats + over J sfloats + sf@ f* fnegate sfax+y8 ELSE mat J 8* sfloats + sfax8 THEN ( mat .mat cr ) \ debugging output LOOP LOOP ; scan-inverse 0 sfloats + Constant x-scl scan-inverse 1 sfloats + Constant y-rots scan-inverse 8 sfloats + Constant x-rots scan-inverse 9 sfloats + Constant y-scl scan-inverse 24 sfloats + Constant x-spos scan-inverse 25 sfloats + Constant y-spos : >scan-matrix ( -- ) scan-inverse matrix-invert4 scan-matrix [ scan-inverse 4 sfloats + ]L [ 32 sfloats ]L bounds ?DO I over [ 4 sfloats ]L move [ 4 sfloats ]L + [ 8 sfloats ]L +LOOP drop -1e 3d-enabler sf! ; \ scan constants $40 Value scan-w scan-w 2/ dup * 1- 2/ 2/ 1+ Constant buf-len scan-w 2* Value scan-right scan-w 2* dup 3 rshift + negate Value scan-left also opengl : draw-scan ( direction xscale yscale -- ) \G draw a scan rotated/tilted by scan matrix fover fnegate fover fnegate 0e { f: sx f: sy f: -sx f: -sy f: z } vi0 >v -sx sy z >xyz n> rot>st white# i>c v+ sx sy z >xyz n> rot>st white# i>c v+ sx -sy z >xyz n> rot>st white# i>c v+ -sx -sy z >xyz n> rot>st white# i>c v+ v> drop 0 i, 1 i, 2 i, 0 i, 2 i, 3 i, GL_TRIANGLES draw-elements ; Variable scan-buf-raw Variable scan-buf0 Variable scan-buf1 Variable red-buf Variable green-buf Variable blue-buf $28 Value blue-level# $70 Value green-level# $70 Value red-level# ' sfloats alias rgbas ( one rgba is the size of an sfloat ) ' sfloat+ alias rgba+ [IFDEF] distdebug 3 cells buffer: dist0 dist0 cell+ Constant dist0-max dist0-max cell+ Constant dist0-min 3 cells buffer: dist1 dist1 cell+ Constant dist1-max dist1-max cell+ Constant dist1-min : ?? ( value level -- flag ) - dup dup 0< IF negate dist0 ELSE dist1 THEN 2dup +! cell+ 2dup @ umax over ! cell+ tuck @ umin swap ! 0< ; [ELSE] ' < alias ?? [THEN] : rgb@ ( addr -- r g b ) >r r@ c@ r@ 1+ c@ r> 2 + c@ ; 0 Value rgb-xor : rgb? ( addr -- rgbbit ) rgb@ blue-level# ?? negate 2* swap green-level# ?? - 2* swap red-level# ?? - rgb-xor xor ; : extract-strip ( addr u step -- strip ) rgbas { step } 0 -rot bounds U+DO 2* 2* I rgb? 3 and + step +LOOP ; $51 buffer: guessbuf guessbuf $40 + Constant guessecc guessecc $10 + Constant guesstag scan-w 3 rshift Constant scan-step : >strip ( index --- addr ) 2* 2* scan-w + scan-w 2* * scan-w + rgbas scan-buf1 $@ rot safe/string drop ; : >strip32 ( addr -- addr' u step ) scan-right - $100 4 ; : >guess ( -- addr u ) guessbuf $40 2dup bounds -8 -rot U+DO dup >strip >strip32 extract-strip I be-l! 1+ 4 +LOOP drop ; : ecc-hor@ ( off -- l ) >strip >strip32 extract-strip ; : ecc-ver@ ( offset -- ul ) #-8 >strip + scan-w dup 3 lshift * scan-w 3 lshift extract-strip ; : tag@ ( -- tag ) #-9 >strip scan-left + $130 [ #17 4 * ]L extract-strip 4 lshift #08 >strip scan-left + $130 [ #17 4 * ]L extract-strip or ; : >guessecc ( -- ) #-9 ecc-hor@ guessecc be-l! #08 ecc-hor@ guessecc 4 + be-l! scan-left ecc-ver@ guessecc 8 + be-l! scan-right ecc-ver@ guessecc $C + be-l! ; : ecc-ok? ( addrkey u1 addrecc u2 -- flag ) 2dup + c@ taghash? ; $8000 Constant init-xy : get-minmax-rgb ( addr u -- minr maxr ming maxg minb maxb ) $FFF -$FFF 2dup 2dup { minr maxr ming maxg minb maxb } bounds ?DO I rgb@ dup maxb max to maxb minb min to minb dup maxg max to maxg ming min to ming dup maxr max to maxr minr min to minr 4 +LOOP minr maxr ming maxg minb maxb ; #10 Cells buffer: p0 p0 2 cells + Constant p1 p1 2 cells + Constant p2 p2 2 cells + Constant p3 p3 2 cells + Constant px : min²! ( x y addr -- ) >r over dup * over dup * + r@ 2@ dup * swap dup * + u< IF r> 2! EXIT THEN 2drop rdrop ; : search-corners ( -- ) init-xy p0 ! p0 p0 cell+ 7 cells cmove \ fill all with the same contents scan-buf0 $@ drop scan-w dup negate DO scan-w dup negate DO dup rgb? dup 4 and IF 3 and 2 xor 2* cells p0 + I J rot min²! ELSE drop THEN rgba+ LOOP LOOP drop ; : ?legit ( -- flag ) p0 2@ init-xy dup d<> p1 2@ init-xy dup d<> and p2 2@ init-xy dup d<> and p3 2@ init-xy dup d<> and ; : compute-xpoint ( -- rx ry ) p0 2@ s>f s>f { f: y0 f: x0 } p3 2@ s>f s>f { f: y1 f: x1 } p1 2@ s>f s>f { f: y2 f: x2 } p2 2@ s>f s>f { f: y3 f: x3 } x0 y1 f* y0 x1 f* f- { f: dxy01 } x2 y3 f* y2 x3 f* f- { f: dxy23 } x0 x1 f- x2 x3 f- { f: dx01 f: dx23 } y0 y1 f- y2 y3 f- { f: dy01 f: dy23 } dx01 dy23 f* dy01 dx23 f* f- 1/f { f: /det1 } dxy01 dx23 f* dxy23 dx01 f* f- /det1 f* \ x dxy01 dy23 f* dxy23 dy01 f* f- /det1 f* \ y fover f>s fdup f>s px 2! ; : p+ ( x1 y1 x2 y2 -- x1+x2 y1+y2 ) rot + >r + r> ; : p2/ ( x1 y1 -- x2 y2 ) 2/ swap 2/ swap ; : p- ( x1 y1 x2 y2 -- x1-x2 y1-y2 ) rot swap - >r - r> ; : scan-grab ( w h addr -- ) >r 0 0 2swap 2dup * rgbas r@ $!len GL_RGBA GL_UNSIGNED_BYTE r> $@ drop glReadPixels ; : scan-grab-buf ( addr -- ) scan-w 2* dup rot scan-grab ; : scan-grab-cam ( addr -- ) cam-w cam-h rot scan-grab ; tex: scan-tex-raw tex: scan-tex tex: scan-tex-final 0 Value scan-fb-raw 0 Value scan-fb 0 Value scan-fb-final : scan-grab-raw ( -- ) cam-w cam-h scan-fb-raw >framebuffer scan-buf-raw scan-grab-cam ; : scan-grab0 ( -- ) scan-buf0 scan-grab-buf ; : scan-grab1 ( -- ) scan-buf1 scan-grab-buf ; also soil 0 Value scan# : save-png0 ( -- ) [: ." scanimg0-" scan# 0 .r ." .png" ;] $tmp SOIL_SAVE_TYPE_PNG 128 dup 4 scan-buf0 $@ drop SOIL_save_image ; : save-png1 ( -- ) [: ." scanimg1-" scan# 0 .r ." .png" ;] $tmp SOIL_SAVE_TYPE_PNG 128 dup 4 scan-buf1 $@ drop SOIL_save_image ; : save-png-raw ( -- ) [: ." scanimgraw-" scan# 0 .r ." .png" ;] $tmp SOIL_SAVE_TYPE_PNG cam-w cam-h 4 scan-buf-raw $@ drop SOIL_save_image ; : save-pngs ( -- ) scan-grab-raw save-png-raw save-png0 save-png1 1 +to scan# 0>framebuffer ; previous : .xpoint ( x y -- ) p0 2@ swap . . space p1 2@ swap . . space p2 2@ swap . . space p3 2@ swap . . space fswap f. f. cr ; : new-scantex-raw ( -- ) scan-tex-raw 0>clear cam-w cam-h GL_RGBA new-textbuffer to scan-fb-raw ; : new-scantex ( -- ) scan-tex 0>clear scan-w 2* dup GL_RGBA new-textbuffer to scan-fb ; : new-scantex-final ( -- ) scan-tex-final 0>clear scan-w 2* dup GL_RGBA new-textbuffer to scan-fb-final ; : new-scantexes ( -- ) scan-fb 0= IF new-scantex-raw new-scantex new-scantex-final 0>framebuffer THEN ; : scale+rotate ( -- ) p1 2@ p0 2@ p- p3 2@ p2 2@ p- p+ p2/ s>f y-scansize f/ y-rots sf! s>f x-scansize f/ x-scl sf! p0 2@ p2 2@ p- p1 2@ p3 2@ p- p+ p2/ s>f y-scansize f/ y-scl sf! s>f x-scansize f/ x-rots sf! ; : set-scan' ( -- ) compute-xpoint ( .. x y ) scale+rotate y-offset f+ scan-w fm/ y-spos sf! x-offset f+ scan-w fm/ x-spos sf! ; : scan-xy ( -- sx sy ) 1e cam-h cam-w over umin swap fm*/ 1e cam-w cam-h over umin fm*/ ; : scan-legit ( -- ) \ resize a legit QR code clear init-scan' set-scan' >scan-matrix scan-matrix MVPMatrix set-matrix scan-matrix MVMatrix set-matrix scan-tex-raw linear-mipmap 0 scan-xy draw-scan scan-grab1 ; : scan-legit? ( -- addr u flag ) [IFDEF] distdebug dist0 off dist0-max off dist0-min on dist1 off dist1-max off dist1-min on [THEN] scan-legit >guess >guessecc tag@ guesstag c! 2dup guessecc $10 ecc-ok? ; Create sat%s 1.0e sf, 1.666e sf, 1.333e sf, 2.0e sf, does> ( n -- ) swap sfloats + sf@ ; : tex-frame ( -- ) program init-program set-uniforms unit-matrix MVPMatrix set-matrix unit-matrix MVMatrix set-matrix ; : draw-scaled ( i -- ) 3 and sat%s saturate% sf! Saturate 1 saturate% glUniform1fv tex-frame scan-w 2* dup scan-fb >framebuffer scan-tex-raw linear-mipmap 0 scan-xy draw-scan scan-grab0 scan-w 2* dup scan-fb-final >framebuffer ; : sat-reset ( sat -- ) saturate% sf! Saturate 1 saturate% glUniform1fv ; previous [IFDEF] android require android/qrscan-android.fs also android [ELSE] [IFDEF] linux require linux/qrscan-linux.fs [THEN] [THEN] [IFUNDEF] scan-result : scan-result ( addr u tag -- ) qr( >r bounds ?DO ." qr : " I $10 xtype cr $10 +LOOP r> ." tag: " dup hex. cr ." ecc: " guessecc $10 xtype cr [IFDEF] distdebug ." dist/min/max: " dist0 @ s>f [ 18 18 * ]L fm/ f>s . dist0-min ? dist0-max ? space dist1 @ s>f [ 18 18 * ]L fm/ f>s . dist1-min ? dist1-max ? cr [THEN] ) ; [THEN] : adapt-rgb ( -- ) scan-buf0 $@ get-minmax-rgb { d: r d: g d: b } b over - 2/ 2/ + to blue-level# \ blue level is 1/4 of total g over - 2 5 */ + to green-level# \ green at 40% of total r over - 2/ + to red-level# ; \ red at 50% of total : scan-it ( -- ) search-corners ?legit IF scan-legit? IF guessecc $10 + c@ scan-result qr( ." took: " .time cr ) qr( save-png1 1 +to scan# ) ELSE 2drop THEN THEN ; : scan-once ( -- ) saturate% sf@ { f: sat } draw-cam qr( !time ) 3 0 DO I draw-scaled adapt-rgb 7 to rgb-xor scan-it 0 to rgb-xor scan-it LOOP sat sat-reset ekey? IF ekey dup k-volup = swap bl = or IF save-pngs THEN THEN ; : scan-loop ( -- ) 1 level# +!@ >r BEGIN scan-once >looper level# @ r@ <= UNTIL rdrop ; : scan-qr ( -- ) [IFDEF] lastscan$ lastscan$ $free [THEN] scan-start ['] scan-loop catch level# off cam-end 0>framebuffer [IFDEF] saturate% 1.0e saturate% sf! [THEN] [IFDEF] showstatus showstatus [THEN] [IFDEF] terminal-program terminal-program terminal-init [THEN] dup IF ." Scan failed" cr ELSE ." Scan completed" cr THEN throw ; previous :noname ( -- ) ?get-me init-client ?nextarg IF s" -many" str= 0= ELSE true THEN to scan-once? scan-qr ; is run-scan-qr \\\ Local Variables: forth-local-words: ( (("net2o:" "+net2o:") definition-starter (font-lock-keyword-face . 1) "[ \t\n]" t name (font-lock-function-name-face . 3)) ("[a-z0-9]+(" immediate (font-lock-comment-face . 1) ")" nil comment (font-lock-comment-face . 1)) ) forth-local-indent-words: ( (("net2o:" "+net2o:") (0 . 2) (0 . 2) non-immediate) ) End: [THEN]