fork download 
  1. MODULE Logo
  2.     IMPLICIT NONE
  3. CONTAINS
  4.  
  5.     FUNCTION TestArea(x,y) result(Hit)
  6.  
  7.         REAL                :: x, y, ty, Angle, Radius
  8.         REAL                :: Pi = 3.14159265358979
  9.         LOGICAL             :: Hit
  10.         REAL                :: RandomDummy
  11.  
  12.         !CALL RANDOM_NUMBER(RandomDummy)
  13.         ! WRITE(*,*) RandomDummy
  14.  
  15.         Hit = .FALSE.
  16.  
  17.         x = ABS(x)
  18.         Angle = ATAN(y/x) ! TODO <= juist hoek bepalen
  19.         Radius = SQRT(x*x+y*y)
  20.  
  21.         IF (y >= 0. .AND. Radius > 0.8 .AND. Radius < 1.) THEN
  22.         !IF (Angle < 0.4 .AND. Radius > 0.8 .AND. Radius < 1.) THEN
  23.             Hit = .TRUE.
  24.         END IF
  25.  
  26.         IF (y < 0. .AND. y > -.3 &
  27.                 .AND. (x-(1.6*y+.3)) > 0.45 .AND. (x-(1.6*y+.3)) < 0.7) THEN
  28.             Hit = .TRUE.
  29.         END IF
  30.  
  31.         IF (y <= -.3 &
  32.             .AND. y > -.55 &
  33.             .AND. (x-(.4*y+.3)+.3) > 0.45 &
  34.             .AND. (x-(.4*y+.3)+.3) < 0.7) THEN
  35.             Hit = .TRUE.
  36.         END IF
  37.  
  38.         IF (x < .1) THEN
  39.             ty = y + .03 * COS(x)
  40.         ELSE
  41.             ty = y
  42.         END IF
  43.  
  44.         IF (ty <= -.55 .AND. ty > -.7) THEN
  45.             IF (x < .5) THEN
  46.                 Hit = .TRUE.
  47.             END IF
  48.         END IF
  49.  
  50.  
  51.     END FUNCTION TestArea
  52.  
  53. END MODULE Logo
  54.  
  55. MODULE RenderAscii
  56.     IMPLICIT NONE
  57. CONTAINS
  58.     FUNCTION TestAreaByColumnRow(Column, Row) RESULT(Hit)
  59.  
  60.         USE Logo, ONLY: TestArea
  61.  
  62.         INTEGER, INTENT(IN) :: Column, Row
  63.         LOGICAL             :: Hit
  64.  
  65.         Hit = TestArea((Column-30) * (2./60), (20-Row) * (2./40))
  66.  
  67.     END FUNCTION TestAreaByColumnRow
  68.  
  69.     FUNCTION GetCharacterFromLogoAA(Column, Row) RESULT(Char)
  70.  
  71.         INTEGER, INTENT(IN) :: Column, Row
  72.         CHARACTER(LEN=1)    :: Char
  73.         INTEGER             :: Neighbours
  74.  
  75.         IF (TestAreaByColumnRow(Column, Row)) THEN
  76.  
  77.             Neighbours = 0
  78.  
  79.             IF (TestAreaByColumnRow(Column,Row-1)) THEN
  80.                 Neighbours = Neighbours + 8 ! IBSET(Neighbours, 3)
  81.             END IF
  82.             IF (TestAreaByColumnRow(Column,Row+1)) THEN
  83.                 Neighbours = Neighbours + 4 ! IBSET(Neighbours, 2)
  84.             END IF
  85.             IF (TestAreaByColumnRow(Column-1,Row)) THEN
  86.                 Neighbours = Neighbours + 2 ! IBSET(Neighbours, 1)
  87.             END IF
  88.             IF (TestAreaByColumnRow(Column+1,Row)) THEN
  89.                 Neighbours = Neighbours + 1 ! IBSET(Neighbours, 0)
  90.             END IF
  91.  
  92.             ! WRITE (*,*) Neighbours
  93.  
  94.             SELECT CASE(Neighbours)
  95.                 CASE(5)
  96.                     Char = 'd'
  97.                 CASE(6)
  98.                     Char = 'b'
  99.                 CASE(10)
  100.                     Char = 'F'
  101.                 CASE(9)
  102.                     Char = 'Y'
  103.                 CASE(4)
  104.                     Char = ';'
  105.                 CASE(8)
  106.                     Char = 'V'
  107.                 CASE(2)
  108.                     Char = '>'
  109.                 CASE(1)
  110.                     Char = '<'
  111.                 CASE(0)
  112.                     Char = '@'
  113.                 CASE DEFAULT
  114.                     Char = 'x'
  115.             END SELECT
  116.         ELSE
  117.             Char = ' '
  118.         END IF
  119.  
  120.     END FUNCTION GetCharacterFromLogoAA
  121.  
  122. END MODULE RenderAscii
  123.  
  124. PROGRAM RenderShellLogo
  125.  
  126.     USE RenderAscii, ONLY: GetCharacterFromLogoAA
  127.  
  128.     IMPLICIT   NONE
  129.  
  130.     INTEGER             :: Column, Row
  131.     CHARACTER(LEN=60)   :: RenderedRow
  132.     LOGICAL             :: Hit
  133.     INTEGER             :: Phase
  134.  
  135.     DO Row=1,40
  136.         DO Column=1,60
  137.             RenderedRow(Column:Column) = GetCharacterFromLogoAA(Column,Row)
  138.         END DO
  139.         WRITE(*,*) RenderedRow
  140.     END DO
  141.  
  142. END PROGRAM RenderShellLogo
  143.  
Success #stdin #stdout 0s 3968KB
comments (?)
stdin 
Standard input is empty
stdout 
                     dxxxxxxxxxxxxxxxxxb                     
                 dxxxxxxxxxxxxxxxxxxxxxxxxxb                 
               dxxxxxxxxxxxxxxxxxxxxxxxxxxxxxb               
             dxxxxxxxxxxxxxxxF Yxxxxxxxxxxxxxxxb             
           dxxxxxxxxxF                 Yxxxxxxxxxb           
         dxxxxxxxxF                       Yxxxxxxxxb         
        dxxxxxxxF                           Yxxxxxxxb        
       dxxxxxxF                               Yxxxxxxb       
     dxxxxxxF                                   Yxxxxxxb     
     xxxxxxF                                     Yxxxxxx     
    dxxxxxF                                       Yxxxxxb    
   dxxxxxF                                         Yxxxxxb   
  dxxxxxF                                           Yxxxxxb  
  xxxxxx                                             xxxxxx  
 dxxxxxF                                             Yxxxxxb 
 xxxxxx                                               xxxxxx 
 xxxxxx                                               xxxxxx 
 xxxxxx                                               xxxxxx 
 xxxxxx                                               xxxxxx 
 Yxxxxx                                               xxxxxF 
   Yxxxxxb                                         dxxxxxF   
     Yxxxxxxb                                   dxxxxxxF     
        Yxxxxxb                               dxxxxxF        
          Yxxxxxxb                         dxxxxxxF          
             xxxxxxb                     dxxxxxx             
             Yxxxxxxb                   dxxxxxxF             
              xxxxxxx                   xxxxxxx              
              Yxxxxxxb                 dxxxxxxF              
               Yxxxxxx                 xxxxxxF               
                xxxxxxb               dxxxxxx                
                xxxxxxxxxxxb     dxxxxxxxxxxx                
                xxxxxxxxxxxxxxxxxxxxxxxxxxxxx                
                YxxxxxxxxxxxxxxxxxxxxxxxxxxxF                
                            YxxxF
https://ideone.com/LRTJEs
language:
Fortran (gfortran 8.3)
created:
10 years ago
visibility:
public

Share or Embed source code

Discover > Sphere Engine API

The brand new service which powers Ideone!

Discover > IDE Widget

Widget for compiling and running the source code in a web browser!